From 49ae38d0f9a56598e142765c9a022a855490ab5b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 25 Aug 2018 11:03:43 +0200 Subject: [PATCH 001/372] using parameters from linked list and removed output homogenization models should only provide model specific output in accordance with http://dx.doi.org/10.1007/s40192-017-0084-5 --- src/homogenization.f90 | 20 +-- src/homogenization_isostrain.f90 | 224 +++++-------------------------- 2 files changed, 39 insertions(+), 205 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 3565999a8..e1d0e9f7c 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -147,7 +147,7 @@ subroutine homogenization_init if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) & call homogenization_none_init() if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) & - call homogenization_isostrain_init(FILEUNIT) + call homogenization_isostrain_init() if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) & call homogenization_RGC_init(FILEUNIT) @@ -207,16 +207,11 @@ subroutine homogenization_init i = homogenization_typeInstance(p) ! which instance of this homogenization type valid = .true. ! assume valid select case(homogenization_type(p)) ! split per homogenization type - case (HOMOGENIZATION_NONE_ID) + case (HOMOGENIZATION_NONE_ID,HOMOGENIZATION_ISOSTRAIN_ID) outputName = HOMOGENIZATION_NONE_label thisNoutput => null() thisOutput => null() thisSize => null() - case (HOMOGENIZATION_ISOSTRAIN_ID) - outputName = HOMOGENIZATION_ISOSTRAIN_label - thisNoutput => homogenization_isostrain_Noutput - thisOutput => homogenization_isostrain_output - thisSize => homogenization_isostrain_sizePostResult case (HOMOGENIZATION_RGC_ID) outputName = HOMOGENIZATION_RGC_label thisNoutput => homogenization_RGC_Noutput @@ -1246,8 +1241,6 @@ function homogenization_postResults(ip,el) POROSITY_phasefield_ID, & HYDROGENFLUX_isoconc_ID, & HYDROGENFLUX_cahnhilliard_ID - use homogenization_isostrain, only: & - homogenization_isostrain_postResults use homogenization_RGC, only: & homogenization_RGC_postResults use thermal_adiabatic, only: & @@ -1286,15 +1279,8 @@ function homogenization_postResults(ip,el) startPos = 1_pInt endPos = homogState(mappingHomogenization(2,ip,el))%sizePostResults chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) - case (HOMOGENIZATION_NONE_ID) chosenHomogenization + case (HOMOGENIZATION_NONE_ID,HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - homogenization_postResults(startPos:endPos) = & - homogenization_isostrain_postResults(& - ip, & - el, & - materialpoint_P(1:3,1:3,ip,el), & - materialpoint_F(1:3,1:3,ip,el)) case (HOMOGENIZATION_RGC_ID) chosenHomogenization homogenization_postResults(startPos:endPos) = & homogenization_RGC_postResults(& diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 8ee0df73d..83396e206 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -9,30 +9,14 @@ module homogenization_isostrain implicit none private - integer(pInt), dimension(:), allocatable, public, protected :: & - homogenization_isostrain_sizePostResults - integer(pInt), dimension(:,:), allocatable, target, public :: & - homogenization_isostrain_sizePostResult - - character(len=64), dimension(:,:), allocatable, target, public :: & - homogenization_isostrain_output !< name of each post result output - integer(pInt), dimension(:), allocatable, target, public :: & - homogenization_isostrain_Noutput !< number of outputs per homog instance integer(pInt), dimension(:), allocatable, private :: & homogenization_isostrain_Ngrains - enum, bind(c) - enumerator :: undefined_ID, & - nconstituents_ID, & - ipcoords_ID, & - avgdefgrad_ID, & - avgfirstpiola_ID - end enum + enum, bind(c) enumerator :: parallel_ID, & average_ID end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - homogenization_isostrain_outputID !< ID of each post result output + integer(kind(average_ID)), dimension(:), allocatable, private :: & homogenization_isostrain_mapping !< mapping type @@ -40,15 +24,14 @@ module homogenization_isostrain public :: & homogenization_isostrain_init, & homogenization_isostrain_partitionDeformation, & - homogenization_isostrain_averageStressAndItsTangent, & - homogenization_isostrain_postResults + homogenization_isostrain_averageStressAndItsTangent contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_init(fileUnit) +subroutine homogenization_isostrain_init() #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & @@ -65,19 +48,15 @@ subroutine homogenization_isostrain_init(fileUnit) use config implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos integer(pInt) :: & - section = 0_pInt, i, mySize, o + h integer :: & maxNinstance, & - homog, & instance integer :: & NofMyHomog ! no pInt (stores a system dependen value from 'count' character(len=65536) :: & - tag = '', & - line = '' + tag = '' write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -88,115 +67,36 @@ subroutine homogenization_isostrain_init(fileUnit) if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(homogenization_isostrain_sizePostResults(maxNinstance), source=0_pInt) - allocate(homogenization_isostrain_sizePostResult(maxval(homogenization_Noutput),maxNinstance), & - source=0_pInt) - allocate(homogenization_isostrain_Noutput(maxNinstance), source=0_pInt) - allocate(homogenization_isostrain_Ngrains(maxNinstance), source=0_pInt) - allocate(homogenization_isostrain_mapping(maxNinstance), source=average_ID) - allocate(homogenization_isostrain_output(maxval(homogenization_Noutput),maxNinstance)) - homogenization_isostrain_output = '' - allocate(homogenization_isostrain_outputID(maxval(homogenization_Noutput),maxNinstance), & - source=undefined_ID) - rewind(fileUnit) - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to - line = IO_read(fileUnit) + allocate(homogenization_isostrain_Ngrains(maxNinstance),source=0_pInt) + allocate(homogenization_isostrain_mapping(maxNinstance),source=average_ID) + + do h = 1_pInt, size(homogenization_type) + if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle + instance = homogenization_typeInstance(h) + + homogenization_isostrain_Ngrains(instance) = config_homogenization(h)%getInt('nconstituents') + tag = 'sum' + tag = config_homogenization(h)%getString('mapping',defaultVal = tag) + select case(trim(tag)) + case ('parallel','sum') + homogenization_isostrain_mapping(instance) = parallel_ID + case ('average','mean','avg') + homogenization_isostrain_mapping(instance) = average_ID + case default + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') + end select + + NofMyHomog = count(material_homog == h) + + homogState(h)%sizeState = 0_pInt + homogState(h)%sizePostResults = 0_pInt + allocate(homogState(h)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state (0_pInt,NofMyHomog), source=0.0_pReal) + enddo - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next section - section = section + 1_pInt - cycle - endif - if (section > 0_pInt ) then ! do not short-circuit here (.and. with next if-statement). It's not safe in Fortran - if (homogenization_type(section) == HOMOGENIZATION_ISOSTRAIN_ID) then ! one of my sections - i = homogenization_typeInstance(section) ! which instance of my type is present homogenization - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case('nconstituents','ngrains') - homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt - homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = nconstituents_ID - homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case('ipcoords') - homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt - homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = ipcoords_ID - homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case('avgdefgrad','avgf') - homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt - homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = avgdefgrad_ID - homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case('avgp','avgfirstpiola','avg1stpiola') - homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt - homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = avgfirstpiola_ID - homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - - end select - case ('nconstituents','ngrains') - homogenization_isostrain_Ngrains(i) = IO_intValue(line,chunkPos,2_pInt) - case ('mapping') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('parallel','sum') - homogenization_isostrain_mapping(i) = parallel_ID - case ('average','mean','avg') - homogenization_isostrain_mapping(i) = average_ID - case default - call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') - end select - - end select - endif - endif - enddo parsingFile - - initializeInstances: do homog = 1_pInt, material_Nhomogenization - myHomog: if (homogenization_type(homog) == HOMOGENIZATION_ISOSTRAIN_ID) then - NofMyHomog = count(material_homog == homog) - instance = homogenization_typeInstance(homog) - -! * Determine size of postResults array - outputsLoop: do o = 1_pInt, homogenization_isostrain_Noutput(instance) - select case(homogenization_isostrain_outputID(o,instance)) - case(nconstituents_ID) - mySize = 1_pInt - case(ipcoords_ID) - mySize = 3_pInt - case(avgdefgrad_ID, avgfirstpiola_ID) - mySize = 9_pInt - case default - mySize = 0_pInt - end select - - outputFound: if (mySize > 0_pInt) then - homogenization_isostrain_sizePostResult(o,instance) = mySize - homogenization_isostrain_sizePostResults(instance) = & - homogenization_isostrain_sizePostResults(instance) + mySize - endif outputFound - enddo outputsLoop - -! allocate state arrays - homogState(homog)%sizeState = 0_pInt - homogState(homog)%sizePostResults = homogenization_isostrain_sizePostResults(instance) - allocate(homogState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) - - endif myHomog - enddo initializeInstances - end subroutine homogenization_isostrain_init @@ -217,9 +117,9 @@ subroutine homogenization_isostrain_partitionDeformation(F,avgF,el) real(pReal), dimension (3,3), intent(in) :: avgF !< my average def grad integer(pInt), intent(in) :: & el !< element number - F=0.0_pReal - F(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)))= & - spread(avgF,3,homogenization_Ngrains(mesh_element(3,el))) + F = 0.0_pReal + F(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el))) = & + spread(avgF,3,homogenization_Ngrains(mesh_element(3,el))) end subroutine homogenization_isostrain_partitionDeformation @@ -261,56 +161,4 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P end subroutine homogenization_isostrain_averageStressAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of homogenization results for post file inclusion -!-------------------------------------------------------------------------------------------------- -pure function homogenization_isostrain_postResults(ip,el,avgP,avgF) - use prec, only: & - pReal - use mesh, only: & - mesh_element, & - mesh_ipCoordinates - use material, only: & - homogenization_typeInstance, & - homogenization_Noutput - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), dimension(3,3), intent(in) :: & - avgP, & !< average stress at material point - avgF !< average deformation gradient at material point - real(pReal), dimension(homogenization_isostrain_sizePostResults & - (homogenization_typeInstance(mesh_element(3,el)))) :: & - homogenization_isostrain_postResults - - integer(pInt) :: & - homID, & - o, c - - c = 0_pInt - homID = homogenization_typeInstance(mesh_element(3,el)) - homogenization_isostrain_postResults = 0.0_pReal - - do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) - select case(homogenization_isostrain_outputID(o,homID)) - case (nconstituents_ID) - homogenization_isostrain_postResults(c+1_pInt) = real(homogenization_isostrain_Ngrains(homID),pReal) - c = c + 1_pInt - case (avgdefgrad_ID) - homogenization_isostrain_postResults(c+1_pInt:c+9_pInt) = reshape(avgF,[9]) - c = c + 9_pInt - case (avgfirstpiola_ID) - homogenization_isostrain_postResults(c+1_pInt:c+9_pInt) = reshape(avgP,[9]) - c = c + 9_pInt - case (ipcoords_ID) - homogenization_isostrain_postResults(c+1_pInt:c+3_pInt) = mesh_ipCoordinates(1:3,ip,el) ! current ip coordinates - c = c + 3_pInt - end select - enddo - -end function homogenization_isostrain_postResults - end module homogenization_isostrain From 6800a5a6f6b87324dfa2eccfd2aee7e8ae29d29c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 25 Aug 2018 11:07:56 +0200 Subject: [PATCH 002/372] just adopting naming convention --- src/homogenization_none.f90 | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/homogenization_none.f90 b/src/homogenization_none.f90 index c33aabe89..18df41209 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_none.f90 @@ -33,26 +33,24 @@ subroutine homogenization_none_init() implicit none integer(pInt) :: & - homog, & + h, & NofMyHomog write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_NONE_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - initializeInstances: do homog = 1_pInt, material_Nhomogenization + do h = 1_pInt, size(homogenization_type) + if (homogenization_type(h) /= HOMOGENIZATION_NONE_ID) cycle - myhomog: if (homogenization_type(homog) == HOMOGENIZATION_none_ID) then - NofMyHomog = count(material_homog == homog) - homogState(homog)%sizeState = 0_pInt - homogState(homog)%sizePostResults = 0_pInt - allocate(homogState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) - - endif myhomog - enddo initializeInstances + NofMyHomog = count(material_homog == h) + homogState(h)%sizeState = 0_pInt + homogState(h)%sizePostResults = 0_pInt + allocate(homogState(h)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state (0_pInt,NofMyHomog), source=0.0_pReal) + enddo end subroutine homogenization_none_init From e6408e0ce3290d7863bcb7522efc9bd04b0e86cb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 26 Aug 2018 21:05:59 +0200 Subject: [PATCH 003/372] corrected careless changes using unallocated pointer and asigning wrong label --- src/homogenization.f90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index e1d0e9f7c..5fce1d247 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -207,11 +207,16 @@ subroutine homogenization_init i = homogenization_typeInstance(p) ! which instance of this homogenization type valid = .true. ! assume valid select case(homogenization_type(p)) ! split per homogenization type - case (HOMOGENIZATION_NONE_ID,HOMOGENIZATION_ISOSTRAIN_ID) + case (HOMOGENIZATION_NONE_ID) outputName = HOMOGENIZATION_NONE_label thisNoutput => null() thisOutput => null() thisSize => null() + case (HOMOGENIZATION_ISOSTRAIN_ID) + outputName = HOMOGENIZATION_ISOSTRAIN_label + thisNoutput => null() + thisOutput => null() + thisSize => null() case (HOMOGENIZATION_RGC_ID) outputName = HOMOGENIZATION_RGC_label thisNoutput => homogenization_RGC_Noutput @@ -224,7 +229,8 @@ subroutine homogenization_init if (valid) then write(FILEUNIT,'(a)') '(type)'//char(9)//trim(outputName) write(FILEUNIT,'(a,i4)') '(ngrains)'//char(9),homogenization_Ngrains(p) - if (homogenization_type(p) /= HOMOGENIZATION_NONE_ID) then + if (homogenization_type(p) /= HOMOGENIZATION_NONE_ID .and. & + homogenization_type(p) /= HOMOGENIZATION_ISOSTRAIN_ID) then do e = 1,thisNoutput(i) write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) enddo From 11a7103675faa7a43d96b43eb5d0dc920b6de4ba Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Aug 2018 00:00:21 +0200 Subject: [PATCH 004/372] more explicit --- src/homogenization_none.f90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/homogenization_none.f90 b/src/homogenization_none.f90 index 18df41209..0e23867f2 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_none.f90 @@ -28,9 +28,13 @@ subroutine homogenization_none_init() pInt use IO, only: & IO_timeStamp - use material - use config - + use material, only: & + homogenization_type, & + material_homog, & + homogState, & + HOMOGENIZATION_NONE_LABEL, & + HOMOGENIZATION_NONE_ID + implicit none integer(pInt) :: & h, & From 331eaabaa40886618245ee1fc2ba52c58142321a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Aug 2018 00:11:15 +0200 Subject: [PATCH 005/372] standard style from plasticity using derived type for parameters explicit "use" to see dependencies --- src/homogenization_isostrain.f90 | 80 ++++++++++++++++++++------------ 1 file changed, 50 insertions(+), 30 deletions(-) diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 83396e206..af16aaddd 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -9,17 +9,19 @@ module homogenization_isostrain implicit none private - integer(pInt), dimension(:), allocatable, private :: & - homogenization_isostrain_Ngrains - enum, bind(c) enumerator :: parallel_ID, & average_ID end enum - integer(kind(average_ID)), dimension(:), allocatable, private :: & - homogenization_isostrain_mapping !< mapping type + type, private :: tParameters !< container type for internal constitutive parameters + integer(pInt) :: & + Nconstituents + integer(kind(average_ID)) :: & + mapping + end type + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) public :: & homogenization_isostrain_init, & @@ -43,9 +45,19 @@ subroutine homogenization_isostrain_init() debug_HOMOGENIZATION, & debug_level, & debug_levelBasic - use IO - use material - use config + use IO, only: & + IO_timeStamp, & + IO_error, & + IO_warning + use material, only: & + homogenization_type, & + material_homog, & + homogState, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_ISOSTRAIN_LABEL, & + homogenization_typeInstance + use config, only: & + config_homogenization implicit none integer(pInt) :: & @@ -57,6 +69,7 @@ subroutine homogenization_isostrain_init() NofMyHomog ! no pInt (stores a system dependen value from 'count' character(len=65536) :: & tag = '' + type(tParameters) :: prm write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -68,21 +81,21 @@ subroutine homogenization_isostrain_init() if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(homogenization_isostrain_Ngrains(maxNinstance),source=0_pInt) - allocate(homogenization_isostrain_mapping(maxNinstance),source=average_ID) + allocate(param(maxNinstance)) ! one container of parameters per instance do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle instance = homogenization_typeInstance(h) + associate(prm => param(instance)) - homogenization_isostrain_Ngrains(instance) = config_homogenization(h)%getInt('nconstituents') + prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') tag = 'sum' tag = config_homogenization(h)%getString('mapping',defaultVal = tag) select case(trim(tag)) - case ('parallel','sum') - homogenization_isostrain_mapping(instance) = parallel_ID - case ('average','mean','avg') - homogenization_isostrain_mapping(instance) = average_ID + case ('sum') + prm%mapping = parallel_ID + case ('avg') + prm%mapping = average_ID case default call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') end select @@ -94,6 +107,7 @@ subroutine homogenization_isostrain_init() allocate(homogState(h)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%state (0_pInt,NofMyHomog), source=0.0_pReal) + end associate enddo @@ -110,16 +124,22 @@ subroutine homogenization_isostrain_partitionDeformation(F,avgF,el) mesh_element use material, only: & homogenization_maxNgrains, & - homogenization_Ngrains + homogenization_typeInstance implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned def grad per grain real(pReal), dimension (3,3), intent(in) :: avgF !< my average def grad - integer(pInt), intent(in) :: & - el !< element number + type(tParameters) :: & + prm + integer(pInt) :: & + el, & + instance + + instance = homogenization_typeInstance(mesh_element(3,el)) + associate(prm => param(instance)) F = 0.0_pReal - F(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el))) = & - spread(avgF,3,homogenization_Ngrains(mesh_element(3,el))) + F(1:3,1:3,1:prm%Nconstituents) = spread(avgF,3,prm%Nconstituents) + end associate end subroutine homogenization_isostrain_partitionDeformation @@ -134,7 +154,6 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P mesh_element use material, only: & homogenization_maxNgrains, & - homogenization_Ngrains, & homogenization_typeInstance implicit none @@ -142,22 +161,23 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses - integer(pInt), intent(in) :: el !< element number + type(tParameters) :: & + prm integer(pInt) :: & - homID, & - Ngrains + el, & + instance - homID = homogenization_typeInstance(mesh_element(3,el)) - Ngrains = homogenization_Ngrains(mesh_element(3,el)) - - select case (homogenization_isostrain_mapping(homID)) + instance = homogenization_typeInstance(mesh_element(3,el)) + associate(prm => param(instance)) + select case (prm%mapping) case (parallel_ID) avgP = sum(P,3) dAvgPdAvgF = sum(dPdF,5) case (average_ID) - avgP = sum(P,3) /real(Ngrains,pReal) - dAvgPdAvgF = sum(dPdF,5)/real(Ngrains,pReal) + avgP = sum(P,3) /real(prm%Nconstituents,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) end select + end associate end subroutine homogenization_isostrain_averageStressAndItsTangent From 9b3ddcd2c2373493abc46fb1152e37063d5d255a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 28 Aug 2018 06:27:38 +0200 Subject: [PATCH 006/372] more explicit --- src/homogenization_isostrain.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index af16aaddd..3ac64e6da 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -137,8 +137,9 @@ subroutine homogenization_isostrain_partitionDeformation(F,avgF,el) instance = homogenization_typeInstance(mesh_element(3,el)) associate(prm => param(instance)) - F = 0.0_pReal F(1:3,1:3,1:prm%Nconstituents) = spread(avgF,3,prm%Nconstituents) + if (homogenization_maxNgrains > prm%Nconstituents) & + F(1:3,1:3,prm%Nconstituents+1_pInt:homogenization_maxNgrains) = 0.0_pReal end associate end subroutine homogenization_isostrain_partitionDeformation From 7f00082d60fb946cf2b2dd8a0d9d9dcb94101f36 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 28 Aug 2018 12:57:22 +0200 Subject: [PATCH 007/372] parameters easier to identify --- src/homogenization_RGC.f90 | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 92ea5301d..84815cded 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -21,16 +21,32 @@ module homogenization_RGC homogenization_RGC_output ! name of each post result output integer(pInt), dimension(:), allocatable,target, public :: & homogenization_RGC_Noutput !< number of outputs per homog instance + + type, private :: tParameters !< container type for internal constitutive parameters + integer(pInt), dimension(:), allocatable :: & + Nconstituents + real(pReal) :: & + xiAlpha, & + ciAlpha + real(pReal), dimension(:), allocatable :: & + dAlpha, & + angles + end type + +! BEGIN DEPRECATED integer(pInt), dimension(:,:), allocatable, private :: & homogenization_RGC_Ngrains real(pReal), dimension(:,:), allocatable, private :: & homogenization_RGC_dAlpha, & homogenization_RGC_angles - real(pReal), dimension(:,:,:,:), allocatable, private :: & - homogenization_RGC_orientation real(pReal), dimension(:), allocatable, private :: & homogenization_RGC_xiAlpha, & homogenization_RGC_ciAlpha +! END DEPRECATED + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + homogenization_RGC_orientation + enum, bind(c) enumerator :: undefined_ID, & constitutivework_ID, & @@ -126,10 +142,11 @@ subroutine homogenization_RGC_init(fileUnit) maxNinstance = int(count(homogenization_type == HOMOGENIZATION_RGC_ID),pInt) if (maxNinstance == 0_pInt) return - if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance allocate(homogenization_RGC_sizeState(maxNinstance), source=0_pInt) allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) + allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) allocate(homogenization_RGC_ciAlpha(maxNinstance), source=0.0_pReal) @@ -149,7 +166,7 @@ subroutine homogenization_RGC_init(fileUnit) line = IO_read(fileUnit) enddo - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part line = IO_read(fileUnit) if (IO_isBlank(line)) cycle ! skip empty lines if (IO_getTag(line,'<','>') /= '') then ! stop at next part From f9214c8e1bbefcfa238f801d292db8e916083f80 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 28 Aug 2018 13:02:44 +0200 Subject: [PATCH 008/372] should not be handled by the individual model avg(P) and avg(F) exist independently of RGC --- src/homogenization_RGC.f90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 84815cded..416db979a 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -162,7 +162,7 @@ subroutine homogenization_RGC_init(fileUnit) homogenization_RGC_orientation = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity rewind(fileUnit) - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>'))/=material_partHomogenization) ! wind forward to + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>'))/=material_partHomogenization) ! wind forward to line = IO_read(fileUnit) enddo @@ -200,12 +200,7 @@ subroutine homogenization_RGC_init(fileUnit) homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = maximumrelaxrate_ID case('magnitudemismatch') homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = magnitudemismatch_ID - case('ipcoords') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = ipcoords_ID - case('avgdefgrad','avgf') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgdefgrad_ID - case('avgp','avgfirstpiola','avg1stpiola') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgfirstpiola_ID + case default homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) -1_pInt ! correct for invalid From 63b939489b610fd71c768ea5cb92f9fdeedf80b1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 28 Aug 2018 13:15:38 +0200 Subject: [PATCH 009/372] reading in parameters using new style in parallel --- src/homogenization_RGC.f90 | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 416db979a..6236e95b7 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -1,9 +1,10 @@ !-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @author Denny Tjahjanto, Max-Planck-Institut für Eisenforschung GmbH !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @brief Relaxed grain cluster (RGC) homogenization scheme -!> Ngrains is defined as p x q x r (cluster) +!> Nconstituents is defined as p x q x r (cluster) !-------------------------------------------------------------------------------------------------- module homogenization_RGC use prec, only: & @@ -62,6 +63,8 @@ module homogenization_RGC integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & homogenization_RGC_outputID !< ID of each post result output + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + public :: & homogenization_RGC_init, & homogenization_RGC_partitionDeformation, & @@ -124,13 +127,14 @@ subroutine homogenization_RGC_init(fileUnit) integer :: & homog, & NofMyHomog, & - o, & + o, h, & instance, & sizeHState integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize, myInstance character(len=65536) :: & tag = '', & line = '' + type(tParameters) :: prm write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_RGC_label//' init -+>>>' write(6,'(/,a)') ' Tjahjanto et al., International Journal of Material Forming, 2(1):939–942, 2009' @@ -161,6 +165,20 @@ subroutine homogenization_RGC_init(fileUnit) allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) homogenization_RGC_orientation = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity + do h = 1_pInt, size(homogenization_type) + if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle + instance = homogenization_typeInstance(h) + associate(prm => param(instance)) + prm%Nconstituents = config_homogenization(h)%getInts('clustersize',requiredShape=[3]) + if (homogenization_Ngrains(section) /= product(prm%Nconstituents)) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') + prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') + prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') + prm%dAlpha = config_homogenization(h)%getFloats('grainsize',requiredShape=[3]) + prm%angles = config_homogenization(h)%getFloats('clusterorientation', requiredShape=[3]) + end associate + enddo + rewind(fileUnit) do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>'))/=material_partHomogenization) ! wind forward to line = IO_read(fileUnit) From ef506b801edb18b321b5d4d882642ea7da194d40 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Aug 2018 09:52:22 +0200 Subject: [PATCH 010/372] fixed two memory faults (unallocated and wrong index) --- src/homogenization_RGC.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 6236e95b7..66825d6f9 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -151,6 +151,8 @@ subroutine homogenization_RGC_init(fileUnit) allocate(homogenization_RGC_sizeState(maxNinstance), source=0_pInt) allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) + allocate(param(maxNinstance)) ! one container of parameters per instance + allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) allocate(homogenization_RGC_ciAlpha(maxNinstance), source=0.0_pReal) @@ -164,13 +166,13 @@ subroutine homogenization_RGC_init(fileUnit) source=0_pInt) allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) homogenization_RGC_orientation = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity - + do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle instance = homogenization_typeInstance(h) associate(prm => param(instance)) prm%Nconstituents = config_homogenization(h)%getInts('clustersize',requiredShape=[3]) - if (homogenization_Ngrains(section) /= product(prm%Nconstituents)) & + if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') From 0b2dd86bbf30d4ae5bb6e9a2cdc52621960782a0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Aug 2018 13:36:46 +0200 Subject: [PATCH 011/372] handling cluster orientation --- src/homogenization_RGC.f90 | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 66825d6f9..4a8b7c6c4 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -165,7 +165,6 @@ subroutine homogenization_RGC_init(fileUnit) allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& source=0_pInt) allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - homogenization_RGC_orientation = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle @@ -177,7 +176,28 @@ subroutine homogenization_RGC_init(fileUnit) prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') prm%dAlpha = config_homogenization(h)%getFloats('grainsize',requiredShape=[3]) - prm%angles = config_homogenization(h)%getFloats('clusterorientation', requiredShape=[3]) + prm%angles = config_homogenization(h)%getFloats('clusterorientation',requiredShape=[3],& + defaultVal=[400.0_pReal,400.0_pReal,400.0_pReal]) + +!-------------------------------------------------------------------------------------------------- +! * assigning cluster orientations + elementLooping: do e = 1_pInt,mesh_NcpElems + if (homogenization_typeInstance(mesh_element(3,e)) == instance) then + noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then + homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) + do i = 2_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + homogenization_RGC_orientation(1:3,1:3,i,e) = merge(homogenization_RGC_orientation(1:3,1:3,1,e), & + math_EulerToR(math_sampleRandomOri()), & + microstructure_elemhomo(mesh_element(4,e))) + enddo + else noOrientationGiven + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(prm%angles*inRad) + enddo + endif noOrientationGiven + endif + enddo elementLooping + end associate enddo From bcff95ddf8b5f74aa3953343050079eb8af7bc12 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Aug 2018 13:52:26 +0200 Subject: [PATCH 012/372] using new values for initialization --- src/homogenization_RGC.f90 | 65 ++++++++++++-------------------------- 1 file changed, 20 insertions(+), 45 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 4a8b7c6c4..baaf7fd8d 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -130,7 +130,7 @@ subroutine homogenization_RGC_init(fileUnit) o, h, & instance, & sizeHState - integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize, myInstance + integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize character(len=65536) :: & tag = '', & line = '' @@ -198,6 +198,16 @@ subroutine homogenization_RGC_init(fileUnit) endif enddo elementLooping + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + write(6,'(a15,1x,i4,/)') 'instance: ', instance + write(6,'(a25,3(1x,i8))') 'cluster size: ',(prm%Nconstituents(j),j=1_pInt,3_pInt) + write(6,'(a25,1x,e10.3)') 'scaling parameter: ', prm%xiAlpha + write(6,'(a25,1x,e10.3)') 'over-proportionality: ', prm%ciAlpha + write(6,'(a25,3(1x,e10.3))') 'grain size: ',(prm%dAlpha(j),j=1_pInt,3_pInt) + write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(prm%angles(j),j=1_pInt,3_pInt) + endif + + homogenization_RGC_Ngrains(:,instance) = prm%nConstituents end associate enddo @@ -269,39 +279,6 @@ subroutine homogenization_RGC_init(fileUnit) endif enddo parsingFile -!-------------------------------------------------------------------------------------------------- -! * assigning cluster orientations - elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_type(mesh_element(3,e)) == HOMOGENIZATION_RGC_ID) then - myInstance = homogenization_typeInstance(mesh_element(3,e)) - if (all (homogenization_RGC_angles(1:3,myInstance) >= 399.9_pReal)) then - homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) - if (microstructure_elemhomo(mesh_element(4,e))) then - homogenization_RGC_orientation(1:3,1:3,i,e) = homogenization_RGC_orientation(1:3,1:3,1,e) - else - homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(math_sampleRandomOri()) - endif - enddo - else - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) - homogenization_RGC_orientation(1:3,1:3,i,e) = & - math_EulerToR(homogenization_RGC_angles(1:3,myInstance)*inRad) - enddo - endif - endif - enddo elementLooping - - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - do i = 1_pInt,maxNinstance - write(6,'(a15,1x,i4,/)') 'instance: ', i - write(6,'(a25,3(1x,i8))') 'cluster size: ',(homogenization_RGC_Ngrains(j,i),j=1_pInt,3_pInt) - write(6,'(a25,1x,e10.3)') 'scaling parameter: ', homogenization_RGC_xiAlpha(i) - write(6,'(a25,1x,e10.3)') 'over-proportionality: ', homogenization_RGC_ciAlpha(i) - write(6,'(a25,3(1x,e10.3))') 'grain size: ',(homogenization_RGC_dAlpha(j,i),j=1_pInt,3_pInt) - write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(homogenization_RGC_angles(j,i),j=1_pInt,3_pInt) - enddo - endif !-------------------------------------------------------------------------------------------------- initializeInstances: do homog = 1_pInt, material_Nhomogenization myHomog: if (homogenization_type(homog) == HOMOGENIZATION_RGC_ID) then @@ -1425,17 +1402,15 @@ end function homogenization_RGC_grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_grain3to1(grain3,homID) +pure function homogenization_RGC_grain3to1(grain3,instance) implicit none integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) + integer(pInt), intent(in) :: instance ! homogenization ID integer(pInt) :: homogenization_RGC_grain3to1 integer(pInt), dimension (3) :: nGDim - integer(pInt), intent(in) :: homID ! homogenization ID -!-------------------------------------------------------------------------------------------------- -! get the grain ID - nGDim = homogenization_RGC_Ngrains(1:3,homID) + nGDim = param(instance)%Nconstituents homogenization_RGC_grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) end function homogenization_RGC_grain3to1 @@ -1444,14 +1419,14 @@ end function homogenization_RGC_grain3to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 4D (normal and local position) into 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function homogenization_RGC_interface4to1(iFace4D, homID) +integer(pInt) pure function homogenization_RGC_interface4to1(iFace4D, instance) implicit none integer(pInt), dimension (4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) integer(pInt), dimension (3) :: nGDim,nIntFace - integer(pInt), intent(in) :: homID !< homogenization ID + integer(pInt), intent(in) :: instance - nGDim = homogenization_RGC_Ngrains(1:3,homID) + nGDim = param(instance)%Nconstituents !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... @@ -1483,15 +1458,15 @@ end function homogenization_RGC_interface4to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 1D (global array) into 4D (normal and local position) !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_interface1to4(iFace1D, homID) +pure function homogenization_RGC_interface1to4(iFace1D, instance) implicit none integer(pInt), dimension (4) :: homogenization_RGC_interface1to4 integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array integer(pInt), dimension (3) :: nGDim,nIntFace - integer(pInt), intent(in) :: homID !< homogenization ID + integer(pInt), intent(in) :: instance - nGDim = homogenization_RGC_Ngrains(:,homID) + nGDim = param(instance)%Nconstituents !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... From 88d776cad6b3193d449a6c9eaf93130bf26c526c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 30 Aug 2018 10:46:30 +0200 Subject: [PATCH 013/372] consistent renames --- src/homogenization_RGC.f90 | 112 ++++++++++++++++++------------------- 1 file changed, 56 insertions(+), 56 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index baaf7fd8d..e4f4a8728 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -355,19 +355,19 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: homID, iGrain,iFace,i,j + integer(pInt) :: instance, iGrain,iFace,i,j integer(pInt), parameter :: nFace = 6_pInt !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - homID = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_element(3,el)) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) - iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) + iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) do iFace = 1_pInt,nFace intFace = homogenization_RGC_getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain - aVect = homogenization_RGC_relaxationVector(intFace,homID, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array + aVect = homogenization_RGC_relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the normal of each interface forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & @@ -443,7 +443,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc integer(pInt), dimension (2) :: residLoc - integer(pInt) homID,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain + integer(pInt) instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain real(pReal), dimension (3,3,homogenization_maxNgrains) :: R,pF,pR,D,pD real(pReal), dimension (3,homogenization_maxNgrains) :: NN,pNN real(pReal), dimension (3) :: normP,normN,mornP,mornN @@ -462,8 +462,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) - homID = homogenization_typeInstance(mesh_element(3,el)) - nGDim = homogenization_RGC_Ngrains(1:3,homID) + instance = homogenization_typeInstance(mesh_element(3,el)) + nGDim = param(instance)%Nconstituents nGrain = homogenization_Ngrains(mesh_element(3,el)) nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) @@ -492,7 +492,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing interface mismatch and stress penalty tensor for all interfaces of all grains - call homogenization_RGC_stressPenalty(R,NN,avgF,F,ip,el,homID) + call homogenization_RGC_stressPenalty(R,NN,avgF,F,ip,el,instance) !-------------------------------------------------------------------------------------------------- ! calculating volume discrepancy and stress penalty related to overall volume discrepancy @@ -519,12 +519,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,homID) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = homogenization_RGC_interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = homogenization_RGC_grain3to1(iGr3N,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal @@ -532,7 +532,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = homogenization_RGC_grain3to1(iGr3P,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal @@ -678,18 +678,18 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,homID) ! assembling of local dPdF into global Jacobian matrix + faceID = homogenization_RGC_interface1to4(iNum,instance) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem - iGrN = homogenization_RGC_grain3to1(iGr3N,homID) ! translate into global grain ID + iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate into global grain ID intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal do iFace = 1_pInt,nFace intFaceN = homogenization_RGC_getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces - iMun = homogenization_RGC_interface4to1(intFaceN,homID) ! translate the interfaces ID into local 4-dimensional index + iMun = homogenization_RGC_interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) @@ -703,13 +703,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem - iGrP = homogenization_RGC_grain3to1(iGr3P,homID) ! translate into global grain ID + iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate into global grain ID intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal do iFace = 1_pInt,nFace intFaceP = homogenization_RGC_getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces - iMun = homogenization_RGC_interface4to1(intFaceP,homID) ! translate the interfaces ID into local 4-dimensional index + iMun = homogenization_RGC_interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) @@ -741,20 +741,20 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = p_relax - call homogenization_RGC_grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state - call homogenization_RGC_stressPenalty(pR,pNN,avgF,pF,ip,el,homID) ! compute stress penalty due to interface mismatch from perturbed state + call homogenization_RGC_grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state + call homogenization_RGC_stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state call homogenization_RGC_volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state p_resid = 0.0_pReal do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,homID) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = homogenization_RGC_interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = homogenization_RGC_grain3to1(iGr3N,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the corresponding interface normal @@ -762,7 +762,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = homogenization_RGC_grain3to1(iGr3P,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the corresponding normal @@ -907,16 +907,16 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, integer(pInt), intent(in) :: el !< element number real(pReal), dimension (9,9) :: dPdF99 - integer(pInt) :: homID, i, j, Ngrains, iGrain + integer(pInt) :: instance, i, j, Nconstituents, iGrain - homID = homogenization_typeInstance(mesh_element(3,el)) - Ngrains = homogenization_Ngrains(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_element(3,el)) + Nconstituents = sum(param(instance)%Nconstituents) !-------------------------------------------------------------------------------------------------- ! debugging the grain tangent if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) - do iGrain = 1_pInt,Ngrains + do iGrain = 1_pInt,Nconstituents dPdF99 = math_Plain3333to99(dPdF(1:3,1:3,1:3,1:3,iGrain)) write(6,'(1x,a30,1x,i3)')'Stress tangent of grain: ',iGrain do i = 1_pInt,9_pInt @@ -930,8 +930,8 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, !-------------------------------------------------------------------------------------------------- ! computing the average first Piola-Kirchhoff stress P and the average tangent dPdF - avgP = sum(P,3)/real(Ngrains,pReal) - dAvgPdAvgF = sum(dPdF,5)/real(Ngrains,pReal) + avgP = sum(P,3)/real(Nconstituents,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(Nconstituents,pReal) end subroutine homogenization_RGC_averageStressAndItsTangent @@ -957,19 +957,21 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) avgP, & !< average stress at material point avgF !< average deformation gradient at material point - integer(pInt) homID,o,c,nIntFaceTot + integer(pInt) instance,o,c,nIntFaceTot + type(tParameters) :: prm real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_element(3,el)))) :: & homogenization_RGC_postResults - homID = homogenization_typeInstance(mesh_element(3,el)) - nIntFaceTot=(homogenization_RGC_Ngrains(1,homID)-1_pInt)*homogenization_RGC_Ngrains(2,homID)*homogenization_RGC_Ngrains(3,homID)& - + homogenization_RGC_Ngrains(1,homID)*(homogenization_RGC_Ngrains(2,homID)-1_pInt)*homogenization_RGC_Ngrains(3,homID)& - + homogenization_RGC_Ngrains(1,homID)*homogenization_RGC_Ngrains(2,homID)*(homogenization_RGC_Ngrains(3,homID)-1_pInt) + instance = homogenization_typeInstance(mesh_element(3,el)) + associate(prm => param(instance)) + nIntFaceTot=(prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)* prm%Nconstituents(3)& + + prm%Nconstituents(1)* (prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3)& + + prm%Nconstituents(1)* prm%Nconstituents(2)* (prm%Nconstituents(3)-1_pInt) c = 0_pInt homogenization_RGC_postResults = 0.0_pReal do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) - select case(homogenization_RGC_outputID(o,homID)) + select case(homogenization_RGC_outputID(o,instance)) case (avgdefgrad_ID) homogenization_RGC_postResults(c+1_pInt:c+9_pInt) = reshape(avgF,[9]) c = c + 9_pInt @@ -1009,14 +1011,14 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) c = c + 1_pInt end select enddo - + end associate end function homogenization_RGC_postResults !-------------------------------------------------------------------------------------------------- !> @brief calculate stress-like penalty due to deformation mismatch !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) +subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) use debug, only: & debug_level, & debug_homogenization,& @@ -1040,19 +1042,19 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el + integer(pInt), intent(in) :: ip,el,instance integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim real(pReal), dimension (3,3) :: gDef,nDef real(pReal), dimension (3) :: nVect,surfCorr real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: homID,iGrain,iGNghb,iFace,i,j,k,l + integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb integer(pInt), parameter :: nFace = 6_pInt real(pReal), parameter :: nDefToler = 1.0e-10_pReal - nGDim = homogenization_RGC_Ngrains(1:3,homID) + nGDim = param(instance)%Nconstituents rPen = 0.0_pReal nMis = 0.0_pReal @@ -1077,7 +1079,7 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) Gmoduli = homogenization_RGC_equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector - iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) ! get the grain ID in local 3-dimensional index (x,y,z)-position + iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position !* Looping over all six interfaces of each grain do iFace = 1_pInt,nFace @@ -1091,7 +1093,7 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt - iGNghb = homogenization_RGC_grain3to1(iGNghb3,homID) ! get the ID of the neighboring grain + iGNghb = homogenization_RGC_grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain Gmoduli = homogenization_RGC_equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) bgGNghb = Gmoduli(2) @@ -1127,9 +1129,9 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) ! compute the stress penalty of all interfaces do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*homogenization_RGC_xiAlpha(homID) & - *surfCorr(abs(intFace(1)))/homogenization_RGC_dAlpha(abs(intFace(1)),homID) & - *cosh(homogenization_RGC_ciAlpha(homID)*nDefNorm) & + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*homogenization_RGC_xiAlpha(instance) & + *surfCorr(abs(intFace(1)))/homogenization_RGC_dAlpha(abs(intFace(1)),instance) & + *cosh(homogenization_RGC_ciAlpha(instance)*nDefNorm) & *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & *tanh(nDefNorm/xSmoo_RGC) enddo; enddo @@ -1298,7 +1300,7 @@ end function homogenization_RGC_equivalentModuli !-------------------------------------------------------------------------------------------------- !> @brief collect relaxation vectors of an interface !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_relaxationVector(intFace,homID, ip, el) +function homogenization_RGC_relaxationVector(intFace,instance, ip, el) use material, only: & homogState, & mappingHomogenization @@ -1310,13 +1312,13 @@ function homogenization_RGC_relaxationVector(intFace,homID, ip, el) integer(pInt), dimension (3) :: nGDim integer(pInt) :: & iNum, & - homID !< homogenization ID + instance !< homogenization ID !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array homogenization_RGC_relaxationVector = 0.0_pReal - nGDim = homogenization_RGC_Ngrains(1:3,homID) - iNum = homogenization_RGC_interface4to1(intFace,homID) ! identify the position of the interface in global state array + nGDim = homogenization_RGC_Ngrains(1:3,instance) + iNum = homogenization_RGC_interface4to1(intFace,instance) ! identify the position of the interface in global state array if (iNum > 0_pInt) homogenization_RGC_relaxationVector = homogState(mappingHomogenization(2,ip,el))% & state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries @@ -1380,18 +1382,16 @@ end function homogenization_RGC_getInterface !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 1D (global array) to in 3D (local position) !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_grain1to3(grain1,homID) +function homogenization_RGC_grain1to3(grain1,instance) implicit none integer(pInt), dimension (3) :: homogenization_RGC_grain1to3 integer(pInt), intent(in) :: & grain1,& !< grain ID in 1D array - homID !< homogenization ID + instance integer(pInt), dimension (3) :: nGDim -!-------------------------------------------------------------------------------------------------- -! get the grain position - nGDim = homogenization_RGC_Ngrains(1:3,homID) + nGDim = param(instance)%Nconstituents homogenization_RGC_grain1to3(3) = 1_pInt+(grain1-1_pInt)/(nGDim(1)*nGDim(2)) homogenization_RGC_grain1to3(2) = 1_pInt+mod((grain1-1_pInt)/nGDim(1),nGDim(2)) homogenization_RGC_grain1to3(1) = 1_pInt+mod((grain1-1_pInt),nGDim(1)) @@ -1544,18 +1544,18 @@ subroutine homogenization_RGC_grainDeformation(F, avgF, ip, el) real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: homID, iGrain,iFace,i,j + integer(pInt) :: instance, iGrain,iFace,i,j integer(pInt), parameter :: nFace = 6_pInt !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - homID = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_element(3,el)) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) - iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) + iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) do iFace = 1_pInt,nFace intFace = homogenization_RGC_getInterface(iFace,iGrain3) - aVect = homogenization_RGC_relaxationVector(intFace,homID, ip, el) + aVect = homogenization_RGC_relaxationVector(intFace,instance, ip, el) nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations From 1f9a6143887dfbbe363fce81258399bd26696da9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 30 Aug 2018 10:50:52 +0200 Subject: [PATCH 014/372] no need to have long prefixes for local variables and functions --- src/homogenization_RGC.f90 | 295 ++++++++++++++++++------------------- 1 file changed, 143 insertions(+), 152 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index e4f4a8728..524ae5790 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -72,18 +72,18 @@ module homogenization_RGC homogenization_RGC_updateState, & homogenization_RGC_postResults private :: & - homogenization_RGC_stressPenalty, & - homogenization_RGC_volumePenalty, & - homogenization_RGC_grainDeformation, & - homogenization_RGC_surfaceCorrection, & - homogenization_RGC_equivalentModuli, & - homogenization_RGC_relaxationVector, & - homogenization_RGC_interfaceNormal, & - homogenization_RGC_getInterface, & - homogenization_RGC_grain1to3, & - homogenization_RGC_grain3to1, & - homogenization_RGC_interface4to1, & - homogenization_RGC_interface1to4 + stressPenalty, & + volumePenalty, & + grainDeformation, & + surfaceCorrection, & + equivalentModuli, & + relaxationVector, & + interfaceNormal, & + getInterface, & + grain1to3, & + grain3to1, & + interface4to1, & + interface1to4 contains @@ -363,13 +363,13 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) instance = homogenization_typeInstance(mesh_element(3,el)) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) - iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) + iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,nFace - intFace = homogenization_RGC_getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain + intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain - aVect = homogenization_RGC_relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array + aVect = relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array - nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the normal of each interface + nVect = interfaceNormal(intFace,ip,el) ! get the normal of each interface forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation enddo @@ -492,11 +492,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing interface mismatch and stress penalty tensor for all interfaces of all grains - call homogenization_RGC_stressPenalty(R,NN,avgF,F,ip,el,instance) + call stressPenalty(R,NN,avgF,F,ip,el,instance) !-------------------------------------------------------------------------------------------------- ! calculating volume discrepancy and stress penalty related to overall volume discrepancy - call homogenization_RGC_volumePenalty(D,volDiscrep,F,avgF,ip,el) + call volumePenalty(D,volDiscrep,F,avgF,ip,el) !-------------------------------------------------------------------------------------------------- ! debugging the mismatch, stress and penalties of grains @@ -519,22 +519,22 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) - normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal + iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = getInterface(2_pInt*faceID(1),iGr3N) + normN = interfaceNormal(intFaceN,ip,el) ! get the interface normal !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) - normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal + iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) + normP = interfaceNormal(intFaceP,ip,el) ! get the interface normal !-------------------------------------------------------------------------------------------------- ! compute the residual of traction at the interface (in local system, 4-dimensional index) @@ -678,18 +678,18 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,instance) ! assembling of local dPdF into global Jacobian matrix + faceID = interface1to4(iNum,instance) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem - iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate into global grain ID - intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system - normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal + iGrN = grain3to1(iGr3N,instance) ! translate into global grain ID + intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system + normN = interfaceNormal(intFaceN,ip,el) ! get the interface normal do iFace = 1_pInt,nFace - intFaceN = homogenization_RGC_getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface - mornN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces - iMun = homogenization_RGC_interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index + intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface + mornN = interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces + iMun = interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) @@ -703,13 +703,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem - iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate into global grain ID - intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system - normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal + iGrP = grain3to1(iGr3P,instance) ! translate into global grain ID + intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system + normP = interfaceNormal(intFaceP,ip,el) ! get the interface normal do iFace = 1_pInt,nFace - intFaceP = homogenization_RGC_getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface - mornP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces - iMun = homogenization_RGC_interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index + intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface + mornP = interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces + iMun = interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) @@ -741,30 +741,30 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = p_relax - call homogenization_RGC_grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state - call homogenization_RGC_stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state - call homogenization_RGC_volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state + call grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state + call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state + call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state p_resid = 0.0_pReal do iNum = 1_pInt,nIntFaceTot - faceID = homogenization_RGC_interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = homogenization_RGC_grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain - normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the corresponding interface normal + iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain + normN = interfaceNormal(intFaceN,ip,el) ! get the corresponding interface normal !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = homogenization_RGC_grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain - normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the corresponding normal + iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain + normP = interfaceNormal(intFaceP,ip,el) ! get the corresponding normal !-------------------------------------------------------------------------------------------------- ! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state @@ -939,7 +939,7 @@ end subroutine homogenization_RGC_averageStressAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of homogenization results for post file inclusion !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_postResults(ip,el,avgP,avgF) +pure function homogenization_RGC_postResults(ip,el,avgP,avgF) result(postResults) use mesh, only: & mesh_element, & mesh_ipCoordinates @@ -960,7 +960,7 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) integer(pInt) instance,o,c,nIntFaceTot type(tParameters) :: prm real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_element(3,el)))) :: & - homogenization_RGC_postResults + postResults instance = homogenization_typeInstance(mesh_element(3,el)) associate(prm => param(instance)) @@ -969,44 +969,35 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) + prm%Nconstituents(1)* prm%Nconstituents(2)* (prm%Nconstituents(3)-1_pInt) c = 0_pInt - homogenization_RGC_postResults = 0.0_pReal + postResults = 0.0_pReal do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) select case(homogenization_RGC_outputID(o,instance)) - case (avgdefgrad_ID) - homogenization_RGC_postResults(c+1_pInt:c+9_pInt) = reshape(avgF,[9]) - c = c + 9_pInt - case (avgfirstpiola_ID) - homogenization_RGC_postResults(c+1_pInt:c+9_pInt) = reshape(avgP,[9]) - c = c + 9_pInt - case (ipcoords_ID) - homogenization_RGC_postResults(c+1_pInt:c+3_pInt) = mesh_ipCoordinates(1:3,ip,el) ! current ip coordinates - c = c + 3_pInt case (constitutivework_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) c = c + 1_pInt case (magnitudemismatch_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+2,mappingHomogenization(1,ip,el)) - homogenization_RGC_postResults(c+2) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+2) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+3,mappingHomogenization(1,ip,el)) - homogenization_RGC_postResults(c+3) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+3) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+4,mappingHomogenization(1,ip,el)) c = c + 3_pInt case (penaltyenergy_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) c = c + 1_pInt case (volumediscrepancy_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+6,mappingHomogenization(1,ip,el)) c = c + 1_pInt case (averagerelaxrate_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+7,mappingHomogenization(1,ip,el)) c = c + 1_pInt case (maximumrelaxrate_ID) - homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) c = c + 1_pInt end select @@ -1018,7 +1009,7 @@ end function homogenization_RGC_postResults !-------------------------------------------------------------------------------------------------- !> @brief calculate stress-like penalty due to deformation mismatch !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) +subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) use debug, only: & debug_level, & debug_homogenization,& @@ -1061,7 +1052,7 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) !-------------------------------------------------------------------------------------------------- ! get the correction factor the modulus of penalty stress representing the evolution of area of ! the interfaces due to deformations - surfCorr = homogenization_RGC_surfaceCorrection(avgF,ip,el) + surfCorr = surfaceCorrection(avgF,ip,el) !-------------------------------------------------------------------------------------------------- ! debugging the surface correction factor @@ -1076,15 +1067,15 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) - Gmoduli = homogenization_RGC_equivalentModuli(iGrain,ip,el) + Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector - iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position + iGrain3 = grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position !* Looping over all six interfaces of each grain do iFace = 1_pInt,nFace - intFace = homogenization_RGC_getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain - nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the interface normal + intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain + nVect = interfaceNormal(intFace,ip,el) ! get the interface normal iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) if (iGNghb3(1) < 1) iGNghb3(1) = nGDim(1) ! with periodicity along e1 direction @@ -1093,8 +1084,8 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt - iGNghb = homogenization_RGC_grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain - Gmoduli = homogenization_RGC_equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor + iGNghb = grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain + Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) bgGNghb = Gmoduli(2) gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! compute the difference/jump in deformation gradeint across the neighbor @@ -1152,13 +1143,13 @@ subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) enddo -end subroutine homogenization_RGC_stressPenalty +end subroutine stressPenalty !-------------------------------------------------------------------------------------------------- !> @brief calculate stress-like penalty due to volume discrepancy !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) +subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) use debug, only: & debug_level, & debug_homogenization,& @@ -1220,20 +1211,20 @@ subroutine homogenization_RGC_volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) endif enddo -end subroutine homogenization_RGC_volumePenalty +end subroutine volumePenalty !-------------------------------------------------------------------------------------------------- !> @brief compute the correction factor accouted for surface evolution (area change) due to ! deformation !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_surfaceCorrection(avgF,ip,el) +function surfaceCorrection(avgF,ip,el) use math, only: & math_invert33, & math_mul33x33 implicit none - real(pReal), dimension(3) :: homogenization_RGC_surfaceCorrection + real(pReal), dimension(3) :: surfaceCorrection real(pReal), dimension(3,3), intent(in) :: avgF !< average F integer(pInt), intent(in) :: ip,& !< integration point number el !< element number @@ -1246,25 +1237,25 @@ function homogenization_RGC_surfaceCorrection(avgF,ip,el) avgC = math_mul33x33(transpose(avgF),avgF) call math_invert33(avgC,invC,detF,error) - homogenization_RGC_surfaceCorrection = 0.0_pReal + surfaceCorrection = 0.0_pReal do iBase = 1_pInt,3_pInt intFace = [iBase,1_pInt,1_pInt,1_pInt] - nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the normal of the interface + nVect = interfaceNormal(intFace,ip,el) ! get the normal of the interface do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - homogenization_RGC_surfaceCorrection(iBase) = & ! compute the component of (the inverse of) the stretch in the direction of the normal - homogenization_RGC_surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) + surfaceCorrection(iBase) = & ! compute the component of (the inverse of) the stretch in the direction of the normal + surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) enddo; enddo - homogenization_RGC_surfaceCorrection(iBase) = & ! get the surface correction factor (area contraction/enlargement) - sqrt(homogenization_RGC_surfaceCorrection(iBase))*detF + surfaceCorrection(iBase) = & ! get the surface correction factor (area contraction/enlargement) + sqrt(surfaceCorrection(iBase))*detF enddo -end function homogenization_RGC_surfaceCorrection +end function surfaceCorrection !-------------------------------------------------------------------------------------------------- !> @brief compute the equivalent shear and bulk moduli from the elasticity tensor !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_equivalentModuli(grainID,ip,el) +function equivalentModuli(grainID,ip,el) use constitutive, only: & constitutive_homogenizedC @@ -1274,7 +1265,7 @@ function homogenization_RGC_equivalentModuli(grainID,ip,el) ip, & !< integration point number el !< element number real(pReal), dimension (6,6) :: elasTens - real(pReal), dimension(2) :: homogenization_RGC_equivalentModuli + real(pReal), dimension(2) :: equivalentModuli real(pReal) :: & cEquiv_11, & cEquiv_12, & @@ -1288,26 +1279,26 @@ function homogenization_RGC_equivalentModuli(grainID,ip,el) cEquiv_12 = (elasTens(1,2) + elasTens(2,3) + elasTens(3,1) + & elasTens(1,3) + elasTens(2,1) + elasTens(3,2))/6.0_pReal cEquiv_44 = (elasTens(4,4) + elasTens(5,5) + elasTens(6,6))/3.0_pReal - homogenization_RGC_equivalentModuli(1) = 0.2_pReal*(cEquiv_11 - cEquiv_12) + 0.6_pReal*cEquiv_44 + equivalentModuli(1) = 0.2_pReal*(cEquiv_11 - cEquiv_12) + 0.6_pReal*cEquiv_44 !-------------------------------------------------------------------------------------------------- ! obtain the length of Burgers vector (could be model dependend) - homogenization_RGC_equivalentModuli(2) = 2.5e-10_pReal + equivalentModuli(2) = 2.5e-10_pReal -end function homogenization_RGC_equivalentModuli +end function equivalentModuli !-------------------------------------------------------------------------------------------------- !> @brief collect relaxation vectors of an interface !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_relaxationVector(intFace,instance, ip, el) +function relaxationVector(intFace,instance, ip, el) use material, only: & homogState, & mappingHomogenization implicit none integer(pInt), intent(in) :: ip, el - real(pReal), dimension (3) :: homogenization_RGC_relaxationVector + real(pReal), dimension (3) :: relaxationVector integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) integer(pInt), dimension (3) :: nGDim integer(pInt) :: & @@ -1316,19 +1307,19 @@ function homogenization_RGC_relaxationVector(intFace,instance, ip, el) !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array - homogenization_RGC_relaxationVector = 0.0_pReal + relaxationVector = 0.0_pReal nGDim = homogenization_RGC_Ngrains(1:3,instance) - iNum = homogenization_RGC_interface4to1(intFace,instance) ! identify the position of the interface in global state array - if (iNum > 0_pInt) homogenization_RGC_relaxationVector = homogState(mappingHomogenization(2,ip,el))% & + iNum = interface4to1(intFace,instance) ! identify the position of the interface in global state array + if (iNum > 0_pInt) relaxationVector = homogState(mappingHomogenization(2,ip,el))% & state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries -end function homogenization_RGC_relaxationVector +end function relaxationVector !-------------------------------------------------------------------------------------------------- !> @brief identify the normal of an interface !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_interfaceNormal(intFace,ip,el) +function interfaceNormal(intFace,ip,el) use debug, only: & debug_homogenization,& debug_levelExtensive @@ -1336,7 +1327,7 @@ function homogenization_RGC_interfaceNormal(intFace,ip,el) math_mul33x3 implicit none - real(pReal), dimension (3) :: homogenization_RGC_interfaceNormal + real(pReal), dimension (3) :: interfaceNormal integer(pInt), dimension (4), intent(in) :: intFace !< interface ID in 4D array (normal and position) integer(pInt), intent(in) :: & ip, & !< integration point number @@ -1345,81 +1336,81 @@ function homogenization_RGC_interfaceNormal(intFace,ip,el) !-------------------------------------------------------------------------------------------------- ! get the normal of the interface, identified from the value of intFace(1) - homogenization_RGC_interfaceNormal = 0.0_pReal + interfaceNormal = 0.0_pReal nPos = abs(intFace(1)) ! identify the position of the interface in global state array - homogenization_RGC_interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis + interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis - homogenization_RGC_interfaceNormal = & - math_mul33x3(homogenization_RGC_orientation(1:3,1:3,ip,el),homogenization_RGC_interfaceNormal) + interfaceNormal = & + math_mul33x3(homogenization_RGC_orientation(1:3,1:3,ip,el),interfaceNormal) ! map the normal vector into sample coordinate system (basis) -end function homogenization_RGC_interfaceNormal +end function interfaceNormal !-------------------------------------------------------------------------------------------------- !> @brief collect six faces of a grain in 4D (normal and position) !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_getInterface(iFace,iGrain3) +function getInterface(iFace,iGrain3) implicit none - integer(pInt), dimension (4) :: homogenization_RGC_getInterface + integer(pInt), dimension (4) :: getInterface integer(pInt), dimension (3), intent(in) :: iGrain3 !< grain ID in 3D array integer(pInt), intent(in) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3) integer(pInt) :: iDir !* Direction of interface normal iDir = (int(real(iFace-1_pInt,pReal)/2.0_pReal,pInt)+1_pInt)*(-1_pInt)**iFace - homogenization_RGC_getInterface(1) = iDir + getInterface(1) = iDir !-------------------------------------------------------------------------------------------------- ! identify the interface position by the direction of its normal - homogenization_RGC_getInterface(2:4) = iGrain3 + getInterface(2:4) = iGrain3 if (iDir < 0_pInt) & ! to have a correlation with coordinate/position in real space - homogenization_RGC_getInterface(1_pInt-iDir) = homogenization_RGC_getInterface(1_pInt-iDir)-1_pInt + getInterface(1_pInt-iDir) = getInterface(1_pInt-iDir)-1_pInt -end function homogenization_RGC_getInterface +end function getInterface !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 1D (global array) to in 3D (local position) !-------------------------------------------------------------------------------------------------- -function homogenization_RGC_grain1to3(grain1,instance) +function grain1to3(grain1,instance) implicit none - integer(pInt), dimension (3) :: homogenization_RGC_grain1to3 + integer(pInt), dimension (3) :: grain1to3 integer(pInt), intent(in) :: & grain1,& !< grain ID in 1D array instance integer(pInt), dimension (3) :: nGDim nGDim = param(instance)%Nconstituents - homogenization_RGC_grain1to3(3) = 1_pInt+(grain1-1_pInt)/(nGDim(1)*nGDim(2)) - homogenization_RGC_grain1to3(2) = 1_pInt+mod((grain1-1_pInt)/nGDim(1),nGDim(2)) - homogenization_RGC_grain1to3(1) = 1_pInt+mod((grain1-1_pInt),nGDim(1)) + grain1to3(3) = 1_pInt+(grain1-1_pInt)/(nGDim(1)*nGDim(2)) + grain1to3(2) = 1_pInt+mod((grain1-1_pInt)/nGDim(1),nGDim(2)) + grain1to3(1) = 1_pInt+mod((grain1-1_pInt),nGDim(1)) -end function homogenization_RGC_grain1to3 +end function grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_grain3to1(grain3,instance) +pure function grain3to1(grain3,instance) implicit none integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) integer(pInt), intent(in) :: instance ! homogenization ID - integer(pInt) :: homogenization_RGC_grain3to1 + integer(pInt) :: grain3to1 integer(pInt), dimension (3) :: nGDim nGDim = param(instance)%Nconstituents - homogenization_RGC_grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) + grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) -end function homogenization_RGC_grain3to1 +end function grain3to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 4D (normal and local position) into 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function homogenization_RGC_interface4to1(iFace4D, instance) +integer(pInt) pure function interface4to1(iFace4D, instance) implicit none integer(pInt), dimension (4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) @@ -1434,34 +1425,34 @@ integer(pInt) pure function homogenization_RGC_interface4to1(iFace4D, instance) nIntFace(2) = nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! ... normal //e2 nIntFace(3) = nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) ! ... normal //e3 - homogenization_RGC_interface4to1 = -1_pInt + interface4to1 = -1_pInt !-------------------------------------------------------------------------------------------------- ! get the corresponding interface ID in 1D global array if (abs(iFace4D(1)) == 1_pInt) then ! interface with normal //e1 - homogenization_RGC_interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & + interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) - if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) homogenization_RGC_interface4to1 = 0_pInt + if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 2_pInt) then ! interface with normal //e2 - homogenization_RGC_interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & + interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) + nIntFace(1) - if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) homogenization_RGC_interface4to1 = 0_pInt + if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 3_pInt) then ! interface with normal //e3 - homogenization_RGC_interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & + interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) + nIntFace(1) + nIntFace(2) - if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) homogenization_RGC_interface4to1 = 0_pInt + if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) interface4to1 = 0_pInt endif -end function homogenization_RGC_interface4to1 +end function interface4to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 1D (global array) into 4D (normal and local position) !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_interface1to4(iFace1D, instance) +pure function interface1to4(iFace1D, instance) implicit none - integer(pInt), dimension (4) :: homogenization_RGC_interface1to4 + integer(pInt), dimension (4) :: interface1to4 integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array integer(pInt), dimension (3) :: nGDim,nIntFace integer(pInt), intent(in) :: instance @@ -1477,57 +1468,57 @@ pure function homogenization_RGC_interface1to4(iFace1D, instance) !-------------------------------------------------------------------------------------------------- ! get the corresponding interface ID in 4D (normal and local position) if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal //e1 - homogenization_RGC_interface1to4(1) = 1_pInt - homogenization_RGC_interface1to4(3) = mod((iFace1D-1_pInt),nGDim(2))+1_pInt - homogenization_RGC_interface1to4(4) = mod(& + interface1to4(1) = 1_pInt + interface1to4(3) = mod((iFace1D-1_pInt),nGDim(2))+1_pInt + interface1to4(4) = mod(& int(& real(iFace1D-1_pInt,pReal)/& real(nGDim(2),pReal)& ,pInt)& ,nGDim(3))+1_pInt - homogenization_RGC_interface1to4(2) = int(& + interface1to4(2) = int(& real(iFace1D-1_pInt,pReal)/& real(nGDim(2),pReal)/& real(nGDim(3),pReal)& ,pInt)+1_pInt elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal //e2 - homogenization_RGC_interface1to4(1) = 2_pInt - homogenization_RGC_interface1to4(4) = mod((iFace1D-nIntFace(1)-1_pInt),nGDim(3))+1_pInt - homogenization_RGC_interface1to4(2) = mod(& + interface1to4(1) = 2_pInt + interface1to4(4) = mod((iFace1D-nIntFace(1)-1_pInt),nGDim(3))+1_pInt + interface1to4(2) = mod(& int(& real(iFace1D-nIntFace(1)-1_pInt,pReal)/& real(nGDim(3),pReal)& ,pInt)& ,nGDim(1))+1_pInt - homogenization_RGC_interface1to4(3) = int(& + interface1to4(3) = int(& real(iFace1D-nIntFace(1)-1_pInt,pReal)/& real(nGDim(3),pReal)/& real(nGDim(1),pReal)& ,pInt)+1_pInt elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal //e3 - homogenization_RGC_interface1to4(1) = 3_pInt - homogenization_RGC_interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1_pInt),nGDim(1))+1_pInt - homogenization_RGC_interface1to4(3) = mod(& + interface1to4(1) = 3_pInt + interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1_pInt),nGDim(1))+1_pInt + interface1to4(3) = mod(& int(& real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& real(nGDim(1),pReal)& ,pInt)& ,nGDim(2))+1_pInt - homogenization_RGC_interface1to4(4) = int(& + interface1to4(4) = int(& real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& real(nGDim(1),pReal)/& real(nGDim(2),pReal)& ,pInt)+1_pInt endif -end function homogenization_RGC_interface1to4 +end function interface1to4 !-------------------------------------------------------------------------------------------------- !> @brief calculating the grain deformation gradient (the same with ! homogenization_RGC_partionDeformation, but used only for perturbation scheme) !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_grainDeformation(F, avgF, ip, el) +subroutine grainDeformation(F, avgF, ip, el) use mesh, only: & mesh_element use material, only: & @@ -1552,17 +1543,17 @@ subroutine homogenization_RGC_grainDeformation(F, avgF, ip, el) instance = homogenization_typeInstance(mesh_element(3,el)) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) - iGrain3 = homogenization_RGC_grain1to3(iGrain,instance) + iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,nFace - intFace = homogenization_RGC_getInterface(iFace,iGrain3) - aVect = homogenization_RGC_relaxationVector(intFace,instance, ip, el) - nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) + intFace = getInterface(iFace,iGrain3) + aVect = relaxationVector(intFace,instance, ip, el) + nVect = interfaceNormal(intFace,ip,el) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient enddo -end subroutine homogenization_RGC_grainDeformation +end subroutine grainDeformation end module homogenization_RGC From 6b45afa72f5b789eb55614212637fe8e5511bb6e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 30 Aug 2018 17:51:31 +0200 Subject: [PATCH 015/372] using parameters from config.f90 --- src/homogenization_RGC.f90 | 56 +++++++++++++------------------------- 1 file changed, 19 insertions(+), 37 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 524ae5790..cddd0524b 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -38,11 +38,7 @@ module homogenization_RGC integer(pInt), dimension(:,:), allocatable, private :: & homogenization_RGC_Ngrains real(pReal), dimension(:,:), allocatable, private :: & - homogenization_RGC_dAlpha, & homogenization_RGC_angles - real(pReal), dimension(:), allocatable, private :: & - homogenization_RGC_xiAlpha, & - homogenization_RGC_ciAlpha ! END DEPRECATED real(pReal), dimension(:,:,:,:), allocatable, private :: & @@ -155,10 +151,6 @@ subroutine homogenization_RGC_init(fileUnit) allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) - allocate(homogenization_RGC_ciAlpha(maxNinstance), source=0.0_pReal) - allocate(homogenization_RGC_xiAlpha(maxNinstance), source=0.0_pReal) - allocate(homogenization_RGC_dAlpha(3,maxNinstance), source=0.0_pReal) - allocate(homogenization_RGC_angles(3,maxNinstance), source=400.0_pReal) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) homogenization_RGC_output='' allocate(homogenization_RGC_outputID(maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) @@ -261,18 +253,6 @@ subroutine homogenization_RGC_init(fileUnit) homogenization_RGC_Ngrains(3,i) = IO_intValue(line,chunkPos,4_pInt) if (homogenization_Ngrains(section) /= product(homogenization_RGC_Ngrains(1:3,i))) & call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') - case ('scalingparameter') - homogenization_RGC_xiAlpha(i) = IO_floatValue(line,chunkPos,2_pInt) - case ('overproportionality') - homogenization_RGC_ciAlpha(i) = IO_floatValue(line,chunkPos,2_pInt) - case ('grainsize') - homogenization_RGC_dAlpha(1,i) = IO_floatValue(line,chunkPos,2_pInt) - homogenization_RGC_dAlpha(2,i) = IO_floatValue(line,chunkPos,3_pInt) - homogenization_RGC_dAlpha(3,i) = IO_floatValue(line,chunkPos,4_pInt) - case ('clusterorientation') - homogenization_RGC_angles(1,i) = IO_floatValue(line,chunkPos,2_pInt) - homogenization_RGC_angles(2,i) = IO_floatValue(line,chunkPos,3_pInt) - homogenization_RGC_angles(3,i) = IO_floatValue(line,chunkPos,4_pInt) end select endif @@ -895,7 +875,6 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, use mesh, only: mesh_element use material, only: & homogenization_maxNgrains, & - homogenization_Ngrains, & homogenization_typeInstance use math, only: math_Plain3333to99 @@ -1042,6 +1021,7 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb + type(tParameters) :: prm integer(pInt), parameter :: nFace = 6_pInt real(pReal), parameter :: nDefToler = 1.0e-10_pReal @@ -1054,6 +1034,7 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) ! the interfaces due to deformations surfCorr = surfaceCorrection(avgF,ip,el) + associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! debugging the surface correction factor if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & @@ -1120,9 +1101,9 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) ! compute the stress penalty of all interfaces do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*homogenization_RGC_xiAlpha(instance) & - *surfCorr(abs(intFace(1)))/homogenization_RGC_dAlpha(abs(intFace(1)),instance) & - *cosh(homogenization_RGC_ciAlpha(instance)*nDefNorm) & + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & + *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & + *cosh(prm%ciAlpha*nDefNorm) & *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & *tanh(nDefNorm/xSmoo_RGC) enddo; enddo @@ -1142,6 +1123,7 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) endif enddo + end associate end subroutine stressPenalty @@ -1338,7 +1320,7 @@ function interfaceNormal(intFace,ip,el) ! get the normal of the interface, identified from the value of intFace(1) interfaceNormal = 0.0_pReal 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(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis interfaceNormal = & math_mul33x3(homogenization_RGC_orientation(1:3,1:3,ip,el),interfaceNormal) @@ -1383,9 +1365,9 @@ function grain1to3(grain1,instance) integer(pInt), dimension (3) :: nGDim nGDim = param(instance)%Nconstituents - grain1to3(3) = 1_pInt+(grain1-1_pInt)/(nGDim(1)*nGDim(2)) - grain1to3(2) = 1_pInt+mod((grain1-1_pInt)/nGDim(1),nGDim(2)) - grain1to3(1) = 1_pInt+mod((grain1-1_pInt),nGDim(1)) + grain1to3 = 1_pInt + [mod((grain1-1_pInt),nGDim(1)), & + mod((grain1-1_pInt)/nGDim(1),nGDim(2)), & + (grain1-1_pInt)/(nGDim(1)*nGDim(2))] end function grain1to3 @@ -1397,9 +1379,9 @@ pure function grain3to1(grain3,instance) implicit none integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) - integer(pInt), intent(in) :: instance ! homogenization ID - integer(pInt) :: grain3to1 - integer(pInt), dimension (3) :: nGDim + integer(pInt), intent(in) :: instance ! homogenization ID + integer(pInt) :: grain3to1 + integer(pInt), dimension (3) :: nGDim nGDim = param(instance)%Nconstituents grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) @@ -1414,8 +1396,8 @@ integer(pInt) pure function interface4to1(iFace4D, instance) implicit none integer(pInt), dimension (4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) + integer(pInt), intent(in) :: instance integer(pInt), dimension (3) :: nGDim,nIntFace - integer(pInt), intent(in) :: instance nGDim = param(instance)%Nconstituents @@ -1452,10 +1434,10 @@ end function interface4to1 pure function interface1to4(iFace1D, instance) implicit none - integer(pInt), dimension (4) :: interface1to4 - integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array - integer(pInt), dimension (3) :: nGDim,nIntFace - integer(pInt), intent(in) :: instance + integer(pInt), dimension (4) :: interface1to4 + integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array + integer(pInt), intent(in) :: instance + integer(pInt), dimension (3) :: nGDim,nIntFace nGDim = param(instance)%Nconstituents @@ -1542,7 +1524,7 @@ subroutine grainDeformation(F, avgF, ip, el) ! compute the deformation gradient of individual grains due to relaxations instance = homogenization_typeInstance(mesh_element(3,el)) F = 0.0_pReal - do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + do iGrain = 1_pInt,sum(param(instance)%Nconstituents) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,nFace intFace = getInterface(iFace,iGrain3) From 91a3b4ed6927fc5eec642548cfaee316ac2b76b9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 31 Aug 2018 01:24:28 +0200 Subject: [PATCH 016/372] almost done --- src/homogenization_RGC.f90 | 175 ++++++++++++++----------------------- 1 file changed, 66 insertions(+), 109 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index cddd0524b..21b8ea096 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -23,27 +23,6 @@ module homogenization_RGC integer(pInt), dimension(:), allocatable,target, public :: & homogenization_RGC_Noutput !< number of outputs per homog instance - type, private :: tParameters !< container type for internal constitutive parameters - integer(pInt), dimension(:), allocatable :: & - Nconstituents - real(pReal) :: & - xiAlpha, & - ciAlpha - real(pReal), dimension(:), allocatable :: & - dAlpha, & - angles - end type - -! BEGIN DEPRECATED - integer(pInt), dimension(:,:), allocatable, private :: & - homogenization_RGC_Ngrains - real(pReal), dimension(:,:), allocatable, private :: & - homogenization_RGC_angles -! END DEPRECATED - - real(pReal), dimension(:,:,:,:), allocatable, private :: & - homogenization_RGC_orientation - enum, bind(c) enumerator :: undefined_ID, & constitutivework_ID, & @@ -56,7 +35,29 @@ module homogenization_RGC avgdefgrad_ID,& avgfirstpiola_ID end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + + type, private :: tParameters !< container type for internal constitutive parameters + integer(pInt), dimension(:), allocatable :: & + Nconstituents + real(pReal) :: & + xiAlpha, & + ciAlpha + real(pReal), dimension(:), allocatable :: & + dAlpha, & + angles + integer(kind(undefined_ID)), dimension(:), allocatable :: & + outputID !< ID of each post result output + end type + +! BEGIN DEPRECATED + integer(pInt), dimension(:,:), allocatable, private :: & + homogenization_RGC_Ngrains +! END DEPRECATED + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + homogenization_RGC_orientation + +integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & homogenization_RGC_outputID !< ID of each post result output type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) @@ -119,24 +120,25 @@ subroutine homogenization_RGC_init(fileUnit) implicit none integer(pInt), intent(in) :: fileUnit !< file pointer to material configuration - integer(pInt), allocatable, dimension(:) :: chunkPos integer :: & homog, & NofMyHomog, & o, h, & + outputSize, & instance, & sizeHState integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize - character(len=65536) :: & - tag = '', & - line = '' + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID !< ID of each post result output + character(len=65536), dimension(:), allocatable :: outputs type(tParameters) :: prm write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_RGC_label//' init -+>>>' write(6,'(/,a)') ' Tjahjanto et al., International Journal of Material Forming, 2(1):939–942, 2009' - write(6,'(/,a)') ' https://doi.org/10.1007/s12289-009-0619-1' + write(6,'(a)') ' https://doi.org/10.1007/s12289-009-0619-1' write(6,'(/,a)') ' Tjahjanto et al., Modelling and Simulation in Materials Science and Engineering, 18:015006, 2010' - write(6,'(/,a)') ' https://doi.org/10.1088/0965-0393/18/1/015006' + write(6,'(a)') ' https://doi.org/10.1088/0965-0393/18/1/015006' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -162,15 +164,50 @@ subroutine homogenization_RGC_init(fileUnit) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle instance = homogenization_typeInstance(h) associate(prm => param(instance)) + prm%Nconstituents = config_homogenization(h)%getInts('clustersize',requiredShape=[3]) + homogenization_RGC_Ngrains(:,instance) = prm%Nconstituents if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & - call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') + call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') prm%dAlpha = config_homogenization(h)%getFloats('grainsize',requiredShape=[3]) prm%angles = config_homogenization(h)%getFloats('clusterorientation',requiredShape=[3],& defaultVal=[400.0_pReal,400.0_pReal,400.0_pReal]) + outputs = config_homogenization(h)%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + case('constitutivework') + outputID = constitutivework_ID + outputSize = 1_pInt + case('penaltyenergy') + outputID = penaltyenergy_ID + outputSize = 1_pInt + case('volumediscrepancy') + outputID = volumediscrepancy_ID + outputSize = 1_pInt + case('averagerelaxrate') + outputID = averagerelaxrate_ID + outputSize = 1_pInt + case('maximumrelaxrate') + outputID = maximumrelaxrate_ID + outputSize = 1_pInt + case('magnitudemismatch') + outputID = magnitudemismatch_ID + outputSize = 3_pInt + case default + if (outputID /= undefined_ID) then + homogenization_RGC_output(i,instance) = outputs(i) + homogenization_RGC_sizePostResult(i,instance) = outputSize + prm%outputID = [prm%outputID , outputID] + endif + end select + enddo + !-------------------------------------------------------------------------------------------------- ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems @@ -199,93 +236,15 @@ subroutine homogenization_RGC_init(fileUnit) write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(prm%angles(j),j=1_pInt,3_pInt) endif - homogenization_RGC_Ngrains(:,instance) = prm%nConstituents end associate enddo - rewind(fileUnit) - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>'))/=material_partHomogenization) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next section - section = section + 1_pInt - cycle - endif - if (section > 0_pInt ) then ! do not short-circuit here (.and. with next if-statement). It's not safe in Fortran - if (homogenization_type(section) == HOMOGENIZATION_RGC_ID) then ! one of my sections - i = homogenization_typeInstance(section) ! which instance of my type is present homogenization - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case('constitutivework') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = constitutivework_ID - case('penaltyenergy') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = penaltyenergy_ID - case('volumediscrepancy') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = volumediscrepancy_ID - case('averagerelaxrate') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = averagerelaxrate_ID - case('maximumrelaxrate') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = maximumrelaxrate_ID - case('magnitudemismatch') - homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = magnitudemismatch_ID - - case default - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) -1_pInt ! correct for invalid - - end select - case ('clustersize') - homogenization_RGC_Ngrains(1,i) = IO_intValue(line,chunkPos,2_pInt) - homogenization_RGC_Ngrains(2,i) = IO_intValue(line,chunkPos,3_pInt) - homogenization_RGC_Ngrains(3,i) = IO_intValue(line,chunkPos,4_pInt) - if (homogenization_Ngrains(section) /= product(homogenization_RGC_Ngrains(1:3,i))) & - call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') - - end select - endif - endif - enddo parsingFile - !-------------------------------------------------------------------------------------------------- initializeInstances: do homog = 1_pInt, material_Nhomogenization myHomog: if (homogenization_type(homog) == HOMOGENIZATION_RGC_ID) then NofMyHomog = count(material_homog == homog) instance = homogenization_typeInstance(homog) -! * Determine size of postResults array - outputsLoop: do o = 1_pInt, homogenization_RGC_Noutput(instance) - select case(homogenization_RGC_outputID(o,instance)) - case(constitutivework_ID,penaltyenergy_ID,volumediscrepancy_ID, & - averagerelaxrate_ID,maximumrelaxrate_ID) - mySize = 1_pInt - case(ipcoords_ID,magnitudemismatch_ID) - mySize = 3_pInt - case(avgdefgrad_ID,avgfirstpiola_ID) - mySize = 9_pInt - case default - mySize = 0_pInt - end select - - outputFound: if (mySize > 0_pInt) then - homogenization_RGC_sizePostResult(o,instance) = mySize - homogenization_RGC_sizePostResults(instance) = & - homogenization_RGC_sizePostResults(instance) + mySize - endif outputFound - enddo outputsLoop - sizeHState = & 3_pInt*(homogenization_RGC_Ngrains(1,instance)-1_pInt)* & homogenization_RGC_Ngrains(2,instance)*homogenization_RGC_Ngrains(3,instance) & @@ -306,8 +265,6 @@ subroutine homogenization_RGC_init(fileUnit) endif myHomog enddo initializeInstances - - end subroutine homogenization_RGC_init From 26d18257d2a7e457ca409b4de34fe324010922ee Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 31 Aug 2018 06:35:30 +0200 Subject: [PATCH 017/372] requested output is stored in prm%outputID --- src/homogenization_RGC.f90 | 61 +++++++++++++------------------------- 1 file changed, 21 insertions(+), 40 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 21b8ea096..caf6c88a8 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -14,7 +14,6 @@ module homogenization_RGC implicit none private integer(pInt), dimension(:), allocatable, public :: & - homogenization_RGC_sizeState, & homogenization_RGC_sizePostResults integer(pInt), dimension(:,:), allocatable,target, public :: & homogenization_RGC_sizePostResult @@ -49,16 +48,12 @@ module homogenization_RGC outputID !< ID of each post result output end type -! BEGIN DEPRECATED +! START: Could be improved integer(pInt), dimension(:,:), allocatable, private :: & homogenization_RGC_Ngrains -! END DEPRECATED - real(pReal), dimension(:,:,:,:), allocatable, private :: & homogenization_RGC_orientation - -integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - homogenization_RGC_outputID !< ID of each post result output +! END: Could be improved type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) @@ -121,7 +116,6 @@ subroutine homogenization_RGC_init(fileUnit) implicit none integer(pInt), intent(in) :: fileUnit !< file pointer to material configuration integer :: & - homog, & NofMyHomog, & o, h, & outputSize, & @@ -146,18 +140,16 @@ subroutine homogenization_RGC_init(fileUnit) if (maxNinstance == 0_pInt) return if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(homogenization_RGC_sizeState(maxNinstance), source=0_pInt) allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) - allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) homogenization_RGC_output='' - allocate(homogenization_RGC_outputID(maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& source=0_pInt) + allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) do h = 1_pInt, size(homogenization_type) @@ -236,34 +228,23 @@ subroutine homogenization_RGC_init(fileUnit) write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(prm%angles(j),j=1_pInt,3_pInt) endif + NofMyHomog = count(material_homog == h) + + sizeHState = & + 3_pInt*(prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & + + 3_pInt*prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)* prm%Nconstituents(3) & + + 3_pInt*prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt) & + + 8_pInt ! (1) Average constitutive work, (2-4) Overall mismatch, (5) Average penalty energy, + ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component + + homogState(h)%sizeState = sizeHState + homogState(h)%sizePostResults = homogenization_RGC_sizePostResults(instance) + allocate(homogState(h)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) + end associate enddo - -!-------------------------------------------------------------------------------------------------- - initializeInstances: do homog = 1_pInt, material_Nhomogenization - myHomog: if (homogenization_type(homog) == HOMOGENIZATION_RGC_ID) then - NofMyHomog = count(material_homog == homog) - instance = homogenization_typeInstance(homog) - - sizeHState = & - 3_pInt*(homogenization_RGC_Ngrains(1,instance)-1_pInt)* & - homogenization_RGC_Ngrains(2,instance)*homogenization_RGC_Ngrains(3,instance) & - + 3_pInt*homogenization_RGC_Ngrains(1,instance)*(homogenization_RGC_Ngrains(2,instance)-1_pInt)* & - homogenization_RGC_Ngrains(3,instance) & - + 3_pInt*homogenization_RGC_Ngrains(1,instance)*homogenization_RGC_Ngrains(2,instance)* & - (homogenization_RGC_Ngrains(3,instance)-1_pInt) & - + 8_pInt ! (1) Average constitutive work, (2-4) Overall mismatch, (5) Average penalty energy, - ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component - -! allocate state arrays - homogState(homog)%sizeState = sizeHState - homogState(homog)%sizePostResults = homogenization_RGC_sizePostResults(instance) - allocate(homogState(homog)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) - allocate(homogState(homog)%state (sizeHState,NofMyHomog), source=0.0_pReal) - - endif myHomog - enddo initializeInstances end subroutine homogenization_RGC_init @@ -906,8 +887,8 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) result(postResults c = 0_pInt postResults = 0.0_pReal - do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) - select case(homogenization_RGC_outputID(o,instance)) + outputsLoop: do o = 1_pInt,size(prm%outputID) + select case(prm%outputID(o)) case (constitutivework_ID) postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) @@ -937,7 +918,7 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) result(postResults state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) c = c + 1_pInt end select - enddo + enddo outputsLoop end associate end function homogenization_RGC_postResults From 17c21dfc92e6c777a75cfb5ca6c34773bf5ccd78 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Oct 2018 18:21:13 +0200 Subject: [PATCH 018/372] mesh_element should not be used anymore --- src/homogenization.f90 | 6 +-- src/homogenization_RGC.f90 | 102 +++++++++++++++++-------------------- 2 files changed, 49 insertions(+), 59 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index eec8d2fba..538a8a19e 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -1163,11 +1163,7 @@ function homogenization_postResults(ip,el) case (HOMOGENIZATION_RGC_ID) chosenHomogenization homogenization_postResults(startPos:endPos) = & - homogenization_RGC_postResults(& - ip, & - el, & - materialpoint_P(1:3,1:3,ip,el), & - materialpoint_F(1:3,1:3,ip,el)) + homogenization_RGC_postResults(ip,el) end select chosenHomogenization startPos = endPos + 1_pInt diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index caf6c88a8..edba1687b 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -20,7 +20,7 @@ module homogenization_RGC character(len=64), dimension(:,:), allocatable,target, public :: & homogenization_RGC_output ! name of each post result output integer(pInt), dimension(:), allocatable,target, public :: & - homogenization_RGC_Noutput !< number of outputs per homog instance + homogenization_RGC_Noutput !< number of outputs per homog instance enum, bind(c) enumerator :: undefined_ID, & @@ -48,9 +48,17 @@ module homogenization_RGC outputID !< ID of each post result output end type + type, private :: tRGCState + real(pReal), pointer, dimension(:,:) :: & + work, & + mismatch, & + penaltyEnergy, & + volumeDiscrepancy, & + relaxationRate_avg, & + relaxationRage_max + end type + ! START: Could be improved - integer(pInt), dimension(:,:), allocatable, private :: & - homogenization_RGC_Ngrains real(pReal), dimension(:,:,:,:), allocatable, private :: & homogenization_RGC_orientation ! END: Could be improved @@ -104,11 +112,10 @@ subroutine homogenization_RGC_init(fileUnit) math_EulerToR,& INRAD use mesh, only: & - mesh_maxNips, & - mesh_NcpElems,& - mesh_element, & - FE_Nips, & - FE_geomtype + mesh_NcpElems,& + mesh_NipsPerElem, & + mesh_homogenizationAt, & + mesh_microstructureAt use IO use material use config @@ -149,8 +156,7 @@ subroutine homogenization_RGC_init(fileUnit) homogenization_RGC_output='' allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& source=0_pInt) - allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) - allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(homogenization_RGC_orientation(3,3,mesh_NipsPerElem,mesh_NcpElems), source=0.0_pReal) do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle @@ -158,7 +164,6 @@ subroutine homogenization_RGC_init(fileUnit) associate(prm => param(instance)) prm%Nconstituents = config_homogenization(h)%getInts('clustersize',requiredShape=[3]) - homogenization_RGC_Ngrains(:,instance) = prm%Nconstituents if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') @@ -203,16 +208,16 @@ subroutine homogenization_RGC_init(fileUnit) !-------------------------------------------------------------------------------------------------- ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_typeInstance(mesh_element(3,e)) == instance) then + if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) - do i = 2_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + do i = 2_pInt,mesh_NipsPerElem homogenization_RGC_orientation(1:3,1:3,i,e) = merge(homogenization_RGC_orientation(1:3,1:3,1,e), & math_EulerToR(math_sampleRandomOri()), & - microstructure_elemhomo(mesh_element(4,e))) + microstructure_elemhomo(mesh_microstructureAt(e))) enddo else noOrientationGiven - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + do i = 1_pInt,mesh_NipsPerElem homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(prm%angles*inRad) enddo endif noOrientationGiven @@ -258,7 +263,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) debug_homogenization, & debug_levelExtensive use mesh, only: & - mesh_element + mesh_homogenizationAt use material, only: & homogenization_maxNgrains, & homogenization_Ngrains,& @@ -278,18 +283,16 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - instance = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) F = 0.0_pReal - do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,nFace intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain - aVect = relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array - nVect = interfaceNormal(intFace,ip,el) ! get the normal of each interface forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & - F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation + F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! resulting relaxed deformation gradient @@ -327,7 +330,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) use math, only: & math_invert use mesh, only: & - mesh_element + mesh_homogenizationAt use material, only: & homogenization_maxNgrains, & homogenization_typeInstance, & @@ -380,9 +383,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) - instance = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) nGDim = param(instance)%Nconstituents - nGrain = homogenization_Ngrains(mesh_element(3,el)) + nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) @@ -426,8 +429,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) write(6,'(/,1x,a30,1x,i3)')'Stress and penalties of grain: ',iGrain do i = 1_pInt,3_pInt write(6,'(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))')(P(i,j,iGrain), j = 1_pInt,3_pInt), & - (R(i,j,iGrain), j = 1_pInt,3_pInt), & - (D(i,j,iGrain), j = 1_pInt,3_pInt) + (R(i,j,iGrain), j = 1_pInt,3_pInt), & + (D(i,j,iGrain), j = 1_pInt,3_pInt) enddo write(6,*)' ' enddo @@ -518,7 +521,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! compute/update the state for postResult, i.e., all energy densities computed by time-integration constitutiveWork = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) penaltyEnergy = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) - do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) ! time-integration loop for the calculating the work and energy + do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) ! time-integration loop for the calculating the work and energy do i = 1_pInt,3_pInt do j = 1_pInt,3_pInt constitutiveWork = constitutiveWork + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) @@ -559,7 +562,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !$OMP END CRITICAL (write2out) endif - deallocate(tract,resid,relax,drelax) return !-------------------------------------------------------------------------------------------------- @@ -575,7 +577,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !$OMP END CRITICAL (write2out) endif - deallocate(tract,resid,relax,drelax) return else ! proceed with computing the Jacobian and state update if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & @@ -796,8 +797,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) flush(6) !$OMP END CRITICAL (write2out) endif - - deallocate(tract,resid,jmatrix,jnverse,relax,drelax,pmatrix,smatrix,p_relax,p_resid) end function homogenization_RGC_updateState @@ -810,7 +809,8 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, debug_level, & debug_homogenization,& debug_levelExtensive - use mesh, only: mesh_element + use mesh, only: & + mesh_homogenizationAt use material, only: & homogenization_maxNgrains, & homogenization_typeInstance @@ -826,7 +826,7 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, integer(pInt) :: instance, i, j, Nconstituents, iGrain - instance = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) Nconstituents = sum(param(instance)%Nconstituents) !-------------------------------------------------------------------------------------------------- @@ -856,10 +856,9 @@ end subroutine homogenization_RGC_averageStressAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of homogenization results for post file inclusion !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_postResults(ip,el,avgP,avgF) result(postResults) +pure function homogenization_RGC_postResults(ip,el) result(postResults) use mesh, only: & - mesh_element, & - mesh_ipCoordinates + mesh_homogenizationAt use material, only: & homogenization_typeInstance,& homogState, & @@ -870,16 +869,13 @@ pure function homogenization_RGC_postResults(ip,el,avgP,avgF) result(postResults integer(pInt), intent(in) :: & ip, & !< integration point number el !< element number - real(pReal), dimension(3,3), intent(in) :: & - avgP, & !< average stress at material point - avgF !< average deformation gradient at material point integer(pInt) instance,o,c,nIntFaceTot type(tParameters) :: prm - real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_element(3,el)))) :: & + real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_homogenizationAt(el)))) :: & postResults - instance = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) associate(prm => param(instance)) nIntFaceTot=(prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)* prm%Nconstituents(3)& + prm%Nconstituents(1)* (prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3)& @@ -934,7 +930,7 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) debug_e, & debug_i use mesh, only: & - mesh_element + mesh_homogenizationAt use constitutive, only: & constitutive_homogenizedC use math, only: & @@ -985,7 +981,7 @@ subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector @@ -1077,7 +1073,7 @@ subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) debug_e, & debug_i use mesh, only: & - mesh_element + mesh_homogenizationAt use math, only: & math_det33, & math_inv33 @@ -1099,7 +1095,7 @@ subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) real(pReal), dimension (homogenization_maxNgrains) :: gVol integer(pInt) :: iGrain,nGrain,i,j - nGrain = homogenization_Ngrains(mesh_element(3,el)) + nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster @@ -1228,7 +1224,7 @@ function relaxationVector(intFace,instance, ip, el) !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array relaxationVector = 0.0_pReal - nGDim = homogenization_RGC_Ngrains(1:3,instance) + nGDim = param(instance)%Nconstituents iNum = interface4to1(intFace,instance) ! identify the position of the interface in global state array if (iNum > 0_pInt) relaxationVector = homogState(mappingHomogenization(2,ip,el))% & state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries @@ -1351,15 +1347,15 @@ integer(pInt) pure function interface4to1(iFace4D, instance) ! get the corresponding interface ID in 1D global array if (abs(iFace4D(1)) == 1_pInt) then ! interface with normal //e1 interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & - + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) + + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 2_pInt) then ! interface with normal //e2 interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & - + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) + nIntFace(1) + + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) + nIntFace(1) if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 3_pInt) then ! interface with normal //e3 interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & - + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) + nIntFace(1) + nIntFace(2) + + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) + nIntFace(1) + nIntFace(2) if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) interface4to1 = 0_pInt endif @@ -1440,10 +1436,9 @@ end function interface1to4 !-------------------------------------------------------------------------------------------------- subroutine grainDeformation(F, avgF, ip, el) use mesh, only: & - mesh_element + mesh_homogenizationAt use material, only: & homogenization_maxNgrains,& - homogenization_Ngrains, & homogenization_typeInstance implicit none @@ -1456,15 +1451,14 @@ subroutine grainDeformation(F, avgF, ip, el) integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 integer(pInt) :: instance, iGrain,iFace,i,j - integer(pInt), parameter :: nFace = 6_pInt !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - instance = homogenization_typeInstance(mesh_element(3,el)) + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) F = 0.0_pReal do iGrain = 1_pInt,sum(param(instance)%Nconstituents) iGrain3 = grain1to3(iGrain,instance) - do iFace = 1_pInt,nFace + do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) aVect = relaxationVector(intFace,instance, ip, el) nVect = interfaceNormal(intFace,ip,el) From 2ca780743850a5911786711a272bad4670bae341 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Oct 2018 22:29:23 +0200 Subject: [PATCH 019/372] cleavage systems avaialable as function --- src/lattice.f90 | 63 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 60 insertions(+), 3 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 996852a79..5d93ab003 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -2126,9 +2126,7 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact case (2_pInt) ! <11.6>{-1-1.1} characteristicShear(ir) = 1.0_pReal/cOverA case (3_pInt) ! <10.-2>{10.1} - characteristicShear(ir) = (4.0_pReal*cOverA*cOverA-9.0_pReal)/4.0_pReal & - / sqrt(3.0_pReal)/cOverA - !characteristicShear(ir) = (4.0_pReal*cOverA*cOverA-9.0_pReal)/sqrt(48.0_pReal)/cOverA + characteristicShear(ir) = (4.0_pReal*cOverA*cOverA-9.0_pReal)/sqrt(48.0_pReal)/cOverA case (4_pInt) ! <11.-3>{11.2} characteristicShear(ir) = 2.0_pReal*(cOverA*cOverA-2.0_pReal)/3.0_pReal/cOverA end select @@ -2662,6 +2660,65 @@ function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) end function lattice_SchmidMatrix_twin +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates Schmid matrix for active cleavage systems +!-------------------------------------------------------------------------------------------------- +function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix) + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_tensorproduct33 + + implicit none + integer(pInt), dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix + real(pReal), intent(in) :: cOverA + + real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: cleavageSystems + integer(pInt), dimension(:), allocatable :: NcleavageMax + integer(pInt) :: i + + select case(structure) + case('iso') + NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE + case('ort') + NcleavageMax = LATTICE_ORTHO_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ORTHO_SYSTEMCLEAVAGE + case('fcc') + NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE + case('bcc') + NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE + case('hex','hexagonal') !ToDo: "No alias policy": long or short? + NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE + case default + call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_SchmidMatrix_cleavage)') + end select + + if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0_pInt)) & + call IO_error(145_pInt,ext_msg='Ncleavage '//trim(structure)) + if (any(Ncleavage < 0_pInt)) & + call IO_error(144_pInt,ext_msg='Ncleavage '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) + + do i = 1, sum(Ncleavage) + SchmidMatrix(1:3,1:3,1,i) = math_tensorproduct33(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,2,i) = math_tensorproduct33(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,3,i) = math_tensorproduct33(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) + enddo + +end function lattice_SchmidMatrix_cleavage + + !-------------------------------------------------------------------------------------------------- !> @brief Populates reduced interaction matrix !-------------------------------------------------------------------------------------------------- From f88b78195afafd6c428975b5352c9117a0f34502 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Oct 2018 10:20:45 +0200 Subject: [PATCH 020/372] not need to repeat shape definition --- src/lattice.f90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 5d93ab003..094ca3409 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -433,7 +433,7 @@ module lattice ! 1, 1, 1, -3, 2, 1, & ! 1, 1,-1, 3,-2, 1, & ! 1,-1, 1, 3, 2,-1 & - ],pReal),[ 3_pInt + 3_pInt ,LATTICE_bcc_Nslip]) + ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) character(len=*), dimension(2), parameter, public :: LATTICE_BCC_SLIPFAMILY_NAME = & ['<1 -1 1>{0 1 1}', & @@ -454,7 +454,7 @@ module lattice 1,-1, 1, -1, 1, 2, & -1, 1, 1, 1,-1, 2, & 1, 1, 1, 1, 1,-2 & - ],pReal),[ 3_pInt + 3_pInt,LATTICE_bcc_Ntwin]) + ],pReal),shape(LATTICE_BCC_SYSTEMTWIN)) character(len=*), dimension(1), parameter, public :: LATTICE_BCC_TWINFAMILY_NAME = & ['<1 1 1>{2 1 1}'] @@ -489,7 +489,7 @@ module lattice 3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, & 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, & 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1 & - ],pInt),[lattice_bcc_Nslip,lattice_bcc_Nslip],order=[2,1]) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 + ],pInt),shape(LATTICE_BCC_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction @@ -523,7 +523,7 @@ module lattice 3,3,3,2,2,3,3,3,3,1,3,3, & 2,3,3,3,3,3,3,2,3,3,1,3, & 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),[LATTICE_bcc_Nslip,LATTICE_bcc_Ntwin],order=[2,1]) !< Slip--twin interaction types for bcc + ],pInt),shape(LATTICE_BCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for bcc !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction @@ -544,7 +544,7 @@ module lattice 3,3,3,2,2,3,3,3,3,1,3,3, & 2,3,3,3,3,3,3,2,3,3,1,3, & 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),[LATTICE_bcc_Ntwin,LATTICE_bcc_Ntwin],order=[2,1]) !< Twin--twin interaction types for bcc + ],pInt),shape(LATTICE_BCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for bcc !< 1: self interaction !< 2: collinear interaction !< 3: other interaction @@ -560,7 +560,7 @@ module lattice 1, 1, 1, -1, 0, 1, & -1, 1, 1, 1, 1, 0, & 1, 1, 1, -1, 1, 0 & - ],pReal),[ 3_pInt + 3_pInt,LATTICE_bcc_Ncleavage]) + ],pReal),shape(LATTICE_BCC_SYSTEMCLEAVAGE)) !-------------------------------------------------------------------------------------------------- ! hexagonal @@ -625,7 +625,7 @@ module lattice -2, 1, 1, 3, 2, -1, -1, 2, & 1, -2, 1, 3, -1, 2, -1, 2, & 1, 1, -2, 3, -1, -1, 2, 2 & - ],pReal),[ 4_pInt + 4_pInt,LATTICE_hex_Nslip]) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr + ],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr character(len=*), dimension(6), parameter, public :: LATTICE_HEX_SLIPFAMILY_NAME = & ['<1 1 . 1>{0 0 . 1} ', & @@ -665,7 +665,7 @@ module lattice -2, 1, 1, -3, -2, 1, 1, 2, & 1, -2, 1, -3, 1, -2, 1, 2, & 1, 1, -2, -3, 1, 1, -2, 2 & - ],pReal),[ 4_pInt + 4_pInt ,LATTICE_hex_Ntwin]) !< twin systems for hex, order follows Prof. Tom Bieler's scheme; but numbering in data was restarted from 1 + ],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, order follows Prof. Tom Bieler's scheme; but numbering in data was restarted from 1 character(len=*), dimension(4), parameter, public :: LATTICE_HEX_TWINFAMILY_NAME = & ['<-1 0 . 1>{1 0 . 2} ', & @@ -742,7 +742,7 @@ module lattice 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & ! - ],pInt),[LATTICE_hex_Nslip,LATTICE_hex_Nslip],order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) + ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Ntwin), parameter, public :: & LATTICE_hex_interactionSlipTwin = reshape(int( [& @@ -785,7 +785,7 @@ module lattice 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & ! - ],pInt),[LATTICE_hex_Nslip,LATTICE_hex_Ntwin],order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) + ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Nslip), parameter, public :: & LATTICE_hex_interactionTwinSlip = reshape(int( [& @@ -816,7 +816,7 @@ module lattice 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & - ],pInt),[LATTICE_hex_Ntwin,LATTICE_hex_Nslip],order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) + ],pInt),shape(LATTICE_HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Ntwin), parameter, public :: & LATTICE_hex_interactionTwinTwin = reshape(int( [& @@ -847,7 +847,7 @@ module lattice 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & - ],pInt),[lattice_hex_Ntwin,lattice_hex_Ntwin],order=[2,1]) !< Twin--slip interaction types for hex (isotropic, 16 in total) + ],pInt),shape(LATTICE_HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--slip interaction types for hex (isotropic, 16 in total) real(pReal), dimension(4+4,LATTICE_hex_Ncleavage), parameter, private :: & LATTICE_hex_systemCleavage = reshape(real([& @@ -855,7 +855,7 @@ module lattice 2,-1,-1, 0, 0, 0, 0, 1, & 0, 0, 0, 1, 2,-1,-1, 0, & 0, 0, 0, 1, 0, 1,-1, 0 & - ],pReal),[ 4_pInt + 4_pInt,LATTICE_hex_Ncleavage]) + ],pReal),shape(LATTICE_HEX_SYSTEMCLEAVAGE)) !-------------------------------------------------------------------------------------------------- From a678e9b94f25d5081aa1df10effaea581826e6a7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 15:13:11 +0100 Subject: [PATCH 021/372] bugfixes flaws introduced in 42-xx branch and detected by new test - outputsize was wrong - nconstituents is product along the 3 directions, not the sum --- src/homogenization_RGC.f90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index edba1687b..5c9937e4c 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -197,14 +197,13 @@ subroutine homogenization_RGC_init(fileUnit) outputID = magnitudemismatch_ID outputSize = 3_pInt case default - if (outputID /= undefined_ID) then - homogenization_RGC_output(i,instance) = outputs(i) - homogenization_RGC_sizePostResult(i,instance) = outputSize - prm%outputID = [prm%outputID , outputID] - endif end select + if (outputID /= undefined_ID) then + homogenization_RGC_output(i,instance) = outputs(i) + homogenization_RGC_sizePostResult(i,instance) = outputSize + prm%outputID = [prm%outputID , outputID] + endif enddo - !-------------------------------------------------------------------------------------------------- ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems @@ -243,6 +242,7 @@ subroutine homogenization_RGC_init(fileUnit) ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component homogState(h)%sizeState = sizeHState + homogenization_RGC_sizePostResults(instance) = sum(homogenization_RGC_sizePostResult(:,instance)) homogState(h)%sizePostResults = homogenization_RGC_sizePostResults(instance) allocate(homogState(h)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) @@ -1456,7 +1456,7 @@ subroutine grainDeformation(F, avgF, ip, el) ! compute the deformation gradient of individual grains due to relaxations instance = homogenization_typeInstance(mesh_homogenizationAt(el)) F = 0.0_pReal - do iGrain = 1_pInt,sum(param(instance)%Nconstituents) + do iGrain = 1_pInt,product(param(instance)%Nconstituents) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) From a0c3a65b395955b84e06fe3d9c1f117313aa43b9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 15:41:54 +0100 Subject: [PATCH 022/372] Noutput not needed anymore --- src/homogenization.f90 | 5 +---- src/homogenization_RGC.f90 | 1 + 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 538a8a19e..1d07944b8 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -193,17 +193,14 @@ subroutine homogenization_init select case(homogenization_type(p)) ! split per homogenization type case (HOMOGENIZATION_NONE_ID) outputName = HOMOGENIZATION_NONE_label - thisNoutput => null() thisOutput => null() thisSize => null() case (HOMOGENIZATION_ISOSTRAIN_ID) outputName = HOMOGENIZATION_ISOSTRAIN_label - thisNoutput => null() thisOutput => null() thisSize => null() case (HOMOGENIZATION_RGC_ID) outputName = HOMOGENIZATION_RGC_label - thisNoutput => homogenization_RGC_Noutput thisOutput => homogenization_RGC_output thisSize => homogenization_RGC_sizePostResult case default @@ -215,7 +212,7 @@ subroutine homogenization_init write(FILEUNIT,'(a,i4)') '(ngrains)'//char(9),homogenization_Ngrains(p) if (homogenization_type(p) /= HOMOGENIZATION_NONE_ID .and. & homogenization_type(p) /= HOMOGENIZATION_ISOSTRAIN_ID) then - do e = 1,thisNoutput(i) + do e = 1,size(thisOutput(:,i)) write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) enddo endif diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 5c9937e4c..c5c680e2c 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -200,6 +200,7 @@ subroutine homogenization_RGC_init(fileUnit) end select if (outputID /= undefined_ID) then homogenization_RGC_output(i,instance) = outputs(i) + print*, homogenization_RGC_output(i,instance) homogenization_RGC_sizePostResult(i,instance) = outputSize prm%outputID = [prm%outputID , outputID] endif From 08c692bfc1cdd73d6cefc40eae45540fd78b6b82 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 16:40:17 +0100 Subject: [PATCH 023/372] passing in instance simplifies things a lot --- src/homogenization.f90 | 14 ++++++++++++-- src/homogenization_isostrain.f90 | 25 +++++++------------------ 2 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 1d07944b8..f8b6dce89 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -913,6 +913,7 @@ subroutine homogenization_partitionDeformation(ip,el) use material, only: & homogenization_type, & homogenization_maxNgrains, & + homogenization_typeInstance, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & HOMOGENIZATION_RGC_ID @@ -927,6 +928,8 @@ subroutine homogenization_partitionDeformation(ip,el) integer(pInt), intent(in) :: & ip, & !< integration point el !< element number + integer(pInt) :: & + instance chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) @@ -936,10 +939,12 @@ subroutine homogenization_partitionDeformation(ip,el) spread(materialpoint_subF(1:3,1:3,ip,el),3,1) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization + instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_isostrain_partitionDeformation(& crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & materialpoint_subF(1:3,1:3,ip,el),& - el) + instance) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization call homogenization_RGC_partitionDeformation(& crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & @@ -1041,6 +1046,7 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) mesh_element use material, only: & homogenization_type, & + homogenization_typeInstance, & homogenization_maxNgrains, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & @@ -1056,6 +1062,8 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) integer(pInt), intent(in) :: & ip, & !< integration point el !< element number + integer(pInt) :: & + instance chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) case (HOMOGENIZATION_NONE_ID) chosenHomogenization @@ -1064,12 +1072,14 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) = sum(crystallite_dPdF(1:3,1:3,1:3,1:3,1:1,ip,el),5) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization + instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_isostrain_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & - el) + instance) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization call homogenization_RGC_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 3ac64e6da..cdff607bf 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -1,4 +1,5 @@ !-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @brief Isostrain (full constraint Taylor assuption) homogenization scheme @@ -117,25 +118,19 @@ end subroutine homogenization_isostrain_init !-------------------------------------------------------------------------------------------------- !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_partitionDeformation(F,avgF,el) +subroutine homogenization_isostrain_partitionDeformation(F,avgF,instance) use prec, only: & pReal - use mesh, only: & - mesh_element use material, only: & - homogenization_maxNgrains, & - homogenization_typeInstance + homogenization_maxNgrains implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned def grad per grain real(pReal), dimension (3,3), intent(in) :: avgF !< my average def grad + integer(pInt), intent(in) :: instance type(tParameters) :: & prm - integer(pInt) :: & - el, & - instance - instance = homogenization_typeInstance(mesh_element(3,el)) associate(prm => param(instance)) F(1:3,1:3,1:prm%Nconstituents) = spread(avgF,3,prm%Nconstituents) if (homogenization_maxNgrains > prm%Nconstituents) & @@ -148,27 +143,21 @@ end subroutine homogenization_isostrain_partitionDeformation !-------------------------------------------------------------------------------------------------- !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,el) +subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) use prec, only: & pReal - use mesh, only: & - mesh_element use material, only: & - homogenization_maxNgrains, & - homogenization_typeInstance + homogenization_maxNgrains implicit none real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses + integer(pInt), intent(in) :: instance type(tParameters) :: & prm - integer(pInt) :: & - el, & - instance - instance = homogenization_typeInstance(mesh_element(3,el)) associate(prm => param(instance)) select case (prm%mapping) case (parallel_ID) From fdbc20b7390eee43b37e8df4ed3347c9368c322c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 16:50:43 +0100 Subject: [PATCH 024/372] cleaned and unified --- src/homogenization.f90 | 6 ++-- src/homogenization_RGC.f90 | 56 ++++++++++++++------------------ src/homogenization_isostrain.f90 | 14 ++++---- 3 files changed, 34 insertions(+), 42 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index f8b6dce89..e664db0cc 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -129,11 +129,11 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! parse homogenization from config file if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) & - call homogenization_none_init() + call homogenization_none_init if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) & - call homogenization_isostrain_init() + call homogenization_isostrain_init if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) & - call homogenization_RGC_init(FILEUNIT) + call homogenization_RGC_init !-------------------------------------------------------------------------------------------------- ! parse thermal from config file diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index c5c680e2c..d520d092a 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -49,21 +49,23 @@ module homogenization_RGC end type type, private :: tRGCState - real(pReal), pointer, dimension(:,:) :: & + real(pReal), pointer, dimension(:) :: & work, & - mismatch, & penaltyEnergy, & volumeDiscrepancy, & relaxationRate_avg, & relaxationRage_max - end type + real(pReal), pointer, dimension(:,:) :: & + mismatch + end type tRGCState ! START: Could be improved real(pReal), dimension(:,:,:,:), allocatable, private :: & homogenization_RGC_orientation ! END: Could be improved - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + type(tParameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) + type(tRGCState), dimension(:), allocatable, private :: state public :: & homogenization_RGC_init, & @@ -90,7 +92,7 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all necessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_init(fileUnit) +subroutine homogenization_RGC_init() #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & @@ -121,13 +123,12 @@ subroutine homogenization_RGC_init(fileUnit) use config implicit none - integer(pInt), intent(in) :: fileUnit !< file pointer to material configuration - integer :: & + integer(pInt) :: & NofMyHomog, & o, h, & outputSize, & instance, & - sizeHState + sizeHState, nIntFaceTot integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & @@ -150,6 +151,7 @@ subroutine homogenization_RGC_init(fileUnit) allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance + allocate(state(maxNinstance)) ! one container per instance allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) @@ -200,7 +202,6 @@ subroutine homogenization_RGC_init(fileUnit) end select if (outputID /= undefined_ID) then homogenization_RGC_output(i,instance) = outputs(i) - print*, homogenization_RGC_output(i,instance) homogenization_RGC_sizePostResult(i,instance) = outputSize prm%outputID = [prm%outputID , outputID] endif @@ -234,11 +235,10 @@ subroutine homogenization_RGC_init(fileUnit) endif NofMyHomog = count(material_homog == h) - - sizeHState = & - 3_pInt*(prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & - + 3_pInt*prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)* prm%Nconstituents(3) & - + 3_pInt*prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt) & + nIntFaceTot = 3_pInt*( (prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt)) + sizeHState = nIntFaceTot & + 8_pInt ! (1) Average constitutive work, (2-4) Overall mismatch, (5) Average penalty energy, ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component @@ -361,6 +361,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), intent(in) :: & ip, & !< integration point number el !< element number + logical, dimension(2) :: homogenization_RGC_updateState integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc @@ -394,12 +395,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) - allocate(relax(3_pInt*nIntFaceTot)); relax= homogState(mappingHomogenization(2,ip,el))% & - state(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) - allocate(drelax(3_pInt*nIntFaceTot)); drelax= homogState(mappingHomogenization(2,ip,el))% & - state(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) - & - homogState(mappingHomogenization(2,ip,el))% & - state0(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) + relax = homogState(mappingHomogenization(2,ip,el))%state (1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) + drelax = relax & + - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) !-------------------------------------------------------------------------------------------------- ! debugging the obtained state if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then @@ -1145,25 +1143,21 @@ function surfaceCorrection(avgF,ip,el) real(pReal), dimension(3,3), intent(in) :: avgF !< average F integer(pInt), intent(in) :: ip,& !< integration point number el !< element number - real(pReal), dimension(3,3) :: invC,avgC + real(pReal), dimension(3,3) :: invC real(pReal), dimension(3) :: nVect real(pReal) :: detF - integer(pInt), dimension(4) :: intFace integer(pInt) :: i,j,iBase logical :: error - avgC = math_mul33x33(transpose(avgF),avgF) - call math_invert33(avgC,invC,detF,error) + call math_invert33(math_mul33x33(transpose(avgF),avgF),invC,detF,error) + surfaceCorrection = 0.0_pReal do iBase = 1_pInt,3_pInt - intFace = [iBase,1_pInt,1_pInt,1_pInt] - nVect = interfaceNormal(intFace,ip,el) ! get the normal of the interface + nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],ip,el) ! get the normal of the interface do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - surfaceCorrection(iBase) = & ! compute the component of (the inverse of) the stretch in the direction of the normal - surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) + surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal enddo; enddo - surfaceCorrection(iBase) = & ! get the surface correction factor (area contraction/enlargement) - sqrt(surfaceCorrection(iBase))*detF + surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) enddo end function surfaceCorrection @@ -1314,7 +1308,7 @@ pure function grain3to1(grain3,instance) implicit none integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) - integer(pInt), intent(in) :: instance ! homogenization ID + integer(pInt), intent(in) :: instance ! homogenization ID integer(pInt) :: grain3to1 integer(pInt), dimension (3) :: nGDim diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index cdff607bf..9c7f6752d 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -64,8 +64,7 @@ subroutine homogenization_isostrain_init() integer(pInt) :: & h integer :: & - maxNinstance, & - instance + Ninstance integer :: & NofMyHomog ! no pInt (stores a system dependen value from 'count' character(len=65536) :: & @@ -76,18 +75,17 @@ subroutine homogenization_isostrain_init() write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - maxNinstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) - if (maxNinstance == 0) return + Ninstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) + if (Ninstance == 0) return if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(param(maxNinstance)) ! one container of parameters per instance + allocate(param(Ninstance)) ! one container of parameters per instance do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle - instance = homogenization_typeInstance(h) - associate(prm => param(instance)) + associate(prm => param(homogenization_typeInstance(h))) prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') tag = 'sum' From 0447ea9d740240861ae07401a31a134a87ebf5a6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 20:00:02 +0100 Subject: [PATCH 025/372] starting to introduce state pointers --- src/homogenization_RGC.f90 | 49 +++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index d520d092a..8fe2d5a03 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -249,6 +249,9 @@ subroutine homogenization_RGC_init() allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) + state(instance)%work =>homogState(h)%state(nIntFaceTot+1,:) + state(instance)%penaltyEnergy =>homogState(h)%state(nIntFaceTot+5,:) + end associate enddo @@ -366,11 +369,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc integer(pInt), dimension (2) :: residLoc - integer(pInt) instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain + integer(pInt) instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of real(pReal), dimension (3,3,homogenization_maxNgrains) :: R,pF,pR,D,pD real(pReal), dimension (3,homogenization_maxNgrains) :: NN,pNN real(pReal), dimension (3) :: normP,normN,mornP,mornN - real(pReal) :: residMax,stresMax,constitutiveWork,penaltyEnergy,volDiscrep + real(pReal) :: residMax,stresMax,volDiscrep logical error integer(pInt), parameter :: nFace = 6_pInt @@ -386,6 +389,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) instance = homogenization_typeInstance(mesh_homogenizationAt(el)) + of = mappingHomogenization(1,ip,el) nGDim = param(instance)%Nconstituents nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & @@ -395,16 +399,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) - relax = homogState(mappingHomogenization(2,ip,el))%state (1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) + relax = homogState(mappingHomogenization(2,ip,el))%state (1:3_pInt*nIntFaceTot,of) drelax = relax & - - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) + - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,of) !-------------------------------------------------------------------------------------------------- ! debugging the obtained state if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Obtained state: ' do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,mappingHomogenization(1,ip,el)) + write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,of) enddo write(6,*)' ' !$OMP END CRITICAL (write2out) @@ -518,42 +522,39 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - constitutiveWork = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) - penaltyEnergy = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) ! time-integration loop for the calculating the work and energy do i = 1_pInt,3_pInt do j = 1_pInt,3_pInt - constitutiveWork = constitutiveWork + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) - penaltyEnergy = penaltyEnergy + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + state(instance)%work(of) = state(instance)%work(of) & + + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + state(instance)%penaltyEnergy(of) = state(instance)%penaltyEnergy(of) & + + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) enddo enddo enddo homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) = constitutiveWork ! the bulk mechanical/constitutive work + state(3*nIntFaceTot+2,of) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+2,mappingHomogenization(1,ip,el)) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction + state(3*nIntFaceTot+3,of) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+3,mappingHomogenization(1,ip,el)) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction + state(3*nIntFaceTot+4,of) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction + homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+4,mappingHomogenization(1,ip,el)) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction + state(3*nIntFaceTot+6,of) = volDiscrep ! the overall volume discrepancy homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) = penaltyEnergy ! the overall penalty energy - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+6,mappingHomogenization(1,ip,el)) = volDiscrep ! the overall volume discrepancy - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+7,mappingHomogenization(1,ip,el)) = & + state(3*nIntFaceTot+7,of) = & sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) ! the average rate of relaxation vectors homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) = maxval(abs(drelax))/dt ! the maximum rate of relaxation vectors + state(3*nIntFaceTot+8,of) = maxval(abs(drelax))/dt ! the maximum rate of relaxation vectors if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) - write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',constitutiveWork + write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',state(instance)%work(of) write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',sum(NN(1,:))/real(nGrain,pReal), & sum(NN(2,:))/real(nGrain,pReal), & sum(NN(3,:))/real(nGrain,pReal) - write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ',penaltyEnergy + write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ',state(instance)%penaltyEnergy(of) write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ',volDiscrep write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ',maxval(abs(drelax))/dt write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ',sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) @@ -658,7 +659,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do ipert = 1_pInt,3_pInt*nIntFaceTot p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector - homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = p_relax + homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = p_relax call grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state @@ -774,7 +775,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo enddo relax = relax + drelax ! Updateing the state variable for the next iteration - homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = relax + homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = relax if (any(abs(drelax) > maxdRelax_RGC)) then ! Forcing cutback when the incremental change of relaxation vector becomes too large homogenization_RGC_updateState = [.true.,.false.] !$OMP CRITICAL (write2out) @@ -790,7 +791,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Returned state: ' do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,mappingHomogenization(1,ip,el)) + write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,of) enddo write(6,*)' ' flush(6) From 85a2f19b1823de02501b762afa71f620f37019f6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 20:03:23 +0100 Subject: [PATCH 026/372] wrong averaging --- src/homogenization_RGC.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 8fe2d5a03..e26b98b26 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -827,7 +827,7 @@ subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF, integer(pInt) :: instance, i, j, Nconstituents, iGrain instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - Nconstituents = sum(param(instance)%Nconstituents) + Nconstituents = product(param(instance)%Nconstituents) !-------------------------------------------------------------------------------------------------- ! debugging the grain tangent From c16fdec749a262ddb0335063edd11e88ee0105b6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 20:08:18 +0100 Subject: [PATCH 027/372] misplaced debug statement debugging the individual constituents should be done by the constitutive laws --- src/homogenization.f90 | 3 ++- src/homogenization_RGC.f90 | 48 +++++++------------------------------- 2 files changed, 10 insertions(+), 41 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index e664db0cc..708e72fa8 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -1081,12 +1081,13 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) instance) case (HOMOGENIZATION_RGC_ID) chosenHomogenization + instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_RGC_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & - el) + instance) end select chosenHomogenization end subroutine homogenization_averageStressAndItsTangent diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index e26b98b26..1b1b5ba66 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -125,11 +125,11 @@ subroutine homogenization_RGC_init() implicit none integer(pInt) :: & NofMyHomog, & - o, h, & + h, & outputSize, & instance, & sizeHState, nIntFaceTot - integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize + integer(pInt) :: maxNinstance, i,j,e, mySize character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & outputID !< ID of each post result output @@ -804,51 +804,19 @@ end function homogenization_RGC_updateState !-------------------------------------------------------------------------------------------------- !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,el) - use debug, only: & - debug_level, & - debug_homogenization,& - debug_levelExtensive - use mesh, only: & - mesh_homogenizationAt +subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) use material, only: & - homogenization_maxNgrains, & - homogenization_typeInstance - use math, only: math_Plain3333to99 - + homogenization_maxNgrains + implicit none real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses - integer(pInt), intent(in) :: el !< element number - real(pReal), dimension (9,9) :: dPdF99 + integer(pInt), intent(in) :: instance - integer(pInt) :: instance, i, j, Nconstituents, iGrain - - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - Nconstituents = product(param(instance)%Nconstituents) - -!-------------------------------------------------------------------------------------------------- -! debugging the grain tangent - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) - do iGrain = 1_pInt,Nconstituents - dPdF99 = math_Plain3333to99(dPdF(1:3,1:3,1:3,1:3,iGrain)) - write(6,'(1x,a30,1x,i3)')'Stress tangent of grain: ',iGrain - do i = 1_pInt,9_pInt - write(6,'(1x,(e15.8,1x))') (dPdF99(i,j), j = 1_pInt,9_pInt) - enddo - write(6,*)' ' - enddo - flush(6) - !$OMP END CRITICAL (write2out) - endif - -!-------------------------------------------------------------------------------------------------- -! computing the average first Piola-Kirchhoff stress P and the average tangent dPdF - avgP = sum(P,3)/real(Nconstituents,pReal) - dAvgPdAvgF = sum(dPdF,5)/real(Nconstituents,pReal) + avgP = sum(P,3) /real(product(param(instance)%Nconstituents),pReal) + dAvgPdAvgF = sum(dPdF,5)/real(product(param(instance)%Nconstituents),pReal) end subroutine homogenization_RGC_averageStressAndItsTangent From 0aa21e507a9d585d23ec178855fa9073da8f0621 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 21:11:43 +0100 Subject: [PATCH 028/372] functions only used within updatestate --- src/homogenization_RGC.f90 | 645 ++++++++++++++++++------------------- 1 file changed, 322 insertions(+), 323 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 1b1b5ba66..72d838c71 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -74,11 +74,6 @@ module homogenization_RGC homogenization_RGC_updateState, & homogenization_RGC_postResults private :: & - stressPenalty, & - volumePenalty, & - grainDeformation, & - surfaceCorrection, & - equivalentModuli, & relaxationVector, & interfaceNormal, & getInterface, & @@ -797,6 +792,328 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) flush(6) !$OMP END CRITICAL (write2out) endif + + contains + !-------------------------------------------------------------------------------------------------- + !> @brief calculate stress-like penalty due to deformation mismatch + !-------------------------------------------------------------------------------------------------- + subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i + use mesh, only: & + mesh_homogenizationAt + use constitutive, only: & + constitutive_homogenizedC + use math, only: & + math_civita + use material, only: & + homogenization_maxNgrains,& + homogenization_Ngrains + use numerics, only: & + xSmoo_RGC + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen !< stress-like penalty + real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients + real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor + integer(pInt), intent(in) :: ip,el,instance + integer(pInt), dimension (4) :: intFace + integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim + real(pReal), dimension (3,3) :: gDef,nDef + real(pReal), dimension (3) :: nVect,surfCorr + real(pReal), dimension (2) :: Gmoduli + integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l + real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb + + type(tParameters) :: prm + integer(pInt), parameter :: nFace = 6_pInt + real(pReal), parameter :: nDefToler = 1.0e-10_pReal + + nGDim = param(instance)%Nconstituents + rPen = 0.0_pReal + nMis = 0.0_pReal + + !-------------------------------------------------------------------------------------------------- + ! get the correction factor the modulus of penalty stress representing the evolution of area of + ! the interfaces due to deformations + surfCorr = surfaceCorrection(avgF,ip,el) + + associate(prm => param(instance)) + !-------------------------------------------------------------------------------------------------- + ! debugging the surface correction factor + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el + write(6,'(1x,3(e11.4,1x))')(surfCorr(i), i = 1,3) + !$OMP END CRITICAL (write2out) + endif + + !-------------------------------------------------------------------------------------------------- + ! computing the mismatch and penalty stress tensor of all grains + do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) + Gmoduli = equivalentModuli(iGrain,ip,el) + muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain + bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector + iGrain3 = grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position + + !* Looping over all six interfaces of each grain + do iFace = 1_pInt,nFace + intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain + nVect = interfaceNormal(intFace,ip,el) ! get the interface normal + iGNghb3 = iGrain3 ! identify the neighboring grain across the interface + iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) + if (iGNghb3(1) < 1) iGNghb3(1) = nGDim(1) ! with periodicity along e1 direction + if (iGNghb3(1) > nGDim(1)) iGNghb3(1) = 1_pInt + if (iGNghb3(2) < 1) iGNghb3(2) = nGDim(2) ! with periodicity along e2 direction + if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt + if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction + if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt + iGNghb = grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain + Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor + muGNghb = Gmoduli(1) + bgGNghb = Gmoduli(2) + gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! compute the difference/jump in deformation gradeint across the neighbor + + !-------------------------------------------------------------------------------------------------- + ! compute the mismatch tensor of all interfaces + nDefNorm = 0.0_pReal + nDef = 0.0_pReal + do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient + enddo; enddo + nDefNorm = nDefNorm + nDef(i,j)*nDef(i,j) ! compute the norm of the mismatch tensor + enddo; enddo + nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) + nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) + + !-------------------------------------------------------------------------------------------------- + ! debuggin the mismatch tensor + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(nDef(i,j), j = 1,3) + enddo + write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm + !$OMP END CRITICAL (write2out) + endif + + !-------------------------------------------------------------------------------------------------- + ! compute the stress penalty of all interfaces + do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & + *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & + *cosh(prm%ciAlpha*nDefNorm) & + *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & + *tanh(nDefNorm/xSmoo_RGC) + enddo; enddo + enddo; enddo + enddo + + !-------------------------------------------------------------------------------------------------- + ! debugging the stress-like penalty + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(rPen(i,j,iGrain), j = 1,3) + enddo + !$OMP END CRITICAL (write2out) + endif + + enddo + end associate + + end subroutine stressPenalty + + + !-------------------------------------------------------------------------------------------------- + !> @brief calculate stress-like penalty due to volume discrepancy + !-------------------------------------------------------------------------------------------------- + subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i + use mesh, only: & + mesh_homogenizationAt + use math, only: & + math_det33, & + math_inv33 + use material, only: & + homogenization_maxNgrains,& + homogenization_Ngrains + use numerics, only: & + maxVolDiscr_RGC,& + volDiscrMod_RGC,& + volDiscrPow_RGC + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen ! stress-like penalty due to volume + real(pReal), intent(out) :: vDiscrep ! total volume discrepancy + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef ! deformation gradients + real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient + integer(pInt), intent(in) :: ip,& ! integration point + el + real(pReal), dimension (homogenization_maxNgrains) :: gVol + integer(pInt) :: iGrain,nGrain,i,j + + nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) + + !-------------------------------------------------------------------------------------------------- + ! compute the volumes of grains and of cluster + vDiscrep = math_det33(fAvg) ! compute the volume of the cluster + do iGrain = 1_pInt,nGrain + gVol(iGrain) = math_det33(fDef(1:3,1:3,iGrain)) ! compute the volume of individual grains + vDiscrep = vDiscrep - gVol(iGrain)/real(nGrain,pReal) ! calculate the difference/dicrepancy between + ! the volume of the cluster and the the total volume of grains + enddo + + !-------------------------------------------------------------------------------------------------- + ! calculate the stress and penalty due to volume discrepancy + vPen = 0.0_pReal + do iGrain = 1_pInt,nGrain + vPen(:,:,iGrain) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & + sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & + gVol(iGrain)*transpose(math_inv33(fDef(:,:,iGrain))) + + !-------------------------------------------------------------------------------------------------- + ! debugging the stress-like penalty + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a30,i2)')'Volume penalty of grain: ',iGrain + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(vPen(i,j,iGrain), j = 1,3) + enddo + !$OMP END CRITICAL (write2out) + endif + enddo + + end subroutine volumePenalty + + + !-------------------------------------------------------------------------------------------------- + !> @brief compute the correction factor accouted for surface evolution (area change) due to + ! deformation + !-------------------------------------------------------------------------------------------------- + function surfaceCorrection(avgF,ip,el) + use math, only: & + math_invert33, & + math_mul33x33 + + implicit none + real(pReal), dimension(3) :: surfaceCorrection + real(pReal), dimension(3,3), intent(in) :: avgF !< average F + integer(pInt), intent(in) :: ip,& !< integration point number + el !< element number + real(pReal), dimension(3,3) :: invC + real(pReal), dimension(3) :: nVect + real(pReal) :: detF + integer(pInt) :: i,j,iBase + logical :: error + + call math_invert33(math_mul33x33(transpose(avgF),avgF),invC,detF,error) + + surfaceCorrection = 0.0_pReal + do iBase = 1_pInt,3_pInt + nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],ip,el) ! get the normal of the interface + do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal + enddo; enddo + surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) + enddo + + end function surfaceCorrection + + + !-------------------------------------------------------------------------------------------------- + !> @brief compute the equivalent shear and bulk moduli from the elasticity tensor + !-------------------------------------------------------------------------------------------------- + function equivalentModuli(grainID,ip,el) + use constitutive, only: & + constitutive_homogenizedC + + implicit none + integer(pInt), intent(in) :: & + grainID,& + ip, & !< integration point number + el !< element number + real(pReal), dimension (6,6) :: elasTens + real(pReal), dimension(2) :: equivalentModuli + real(pReal) :: & + cEquiv_11, & + cEquiv_12, & + cEquiv_44 + + elasTens = constitutive_homogenizedC(grainID,ip,el) + + !-------------------------------------------------------------------------------------------------- + ! compute the equivalent shear modulus after Turterltaub and Suiker, JMPS (2005) + cEquiv_11 = (elasTens(1,1) + elasTens(2,2) + elasTens(3,3))/3.0_pReal + cEquiv_12 = (elasTens(1,2) + elasTens(2,3) + elasTens(3,1) + & + elasTens(1,3) + elasTens(2,1) + elasTens(3,2))/6.0_pReal + cEquiv_44 = (elasTens(4,4) + elasTens(5,5) + elasTens(6,6))/3.0_pReal + equivalentModuli(1) = 0.2_pReal*(cEquiv_11 - cEquiv_12) + 0.6_pReal*cEquiv_44 + + !-------------------------------------------------------------------------------------------------- + ! obtain the length of Burgers vector (could be model dependend) + equivalentModuli(2) = 2.5e-10_pReal + + end function equivalentModuli + + + !-------------------------------------------------------------------------------------------------- + !> @brief calculating the grain deformation gradient (the same with + ! homogenization_RGC_partionDeformation, but used only for perturbation scheme) + !-------------------------------------------------------------------------------------------------- + subroutine grainDeformation(F, avgF, ip, el) + use mesh, only: & + mesh_homogenizationAt + use material, only: & + homogenization_maxNgrains,& + homogenization_typeInstance + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain + real(pReal), dimension (3,3), intent(in) :: avgF !< + integer(pInt), intent(in) :: & + el, & !< element number + ip !< integration point number + real(pReal), dimension (3) :: aVect,nVect + integer(pInt), dimension (4) :: intFace + integer(pInt), dimension (3) :: iGrain3 + integer(pInt) :: instance, iGrain,iFace,i,j + + !-------------------------------------------------------------------------------------------------- + ! compute the deformation gradient of individual grains due to relaxations + instance = homogenization_typeInstance(mesh_homogenizationAt(el)) + F = 0.0_pReal + do iGrain = 1_pInt,product(param(instance)%Nconstituents) + iGrain3 = grain1to3(iGrain,instance) + do iFace = 1_pInt,6_pInt + intFace = getInterface(iFace,iGrain3) + aVect = relaxationVector(intFace,instance, ip, el) + nVect = interfaceNormal(intFace,ip,el) + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations + enddo + F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient + enddo + + end subroutine grainDeformation end function homogenization_RGC_updateState @@ -887,285 +1204,7 @@ pure function homogenization_RGC_postResults(ip,el) result(postResults) end function homogenization_RGC_postResults -!-------------------------------------------------------------------------------------------------- -!> @brief calculate stress-like penalty due to deformation mismatch -!-------------------------------------------------------------------------------------------------- -subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) - use debug, only: & - debug_level, & - debug_homogenization,& - debug_levelExtensive, & - debug_e, & - debug_i - use mesh, only: & - mesh_homogenizationAt - use constitutive, only: & - constitutive_homogenizedC - use math, only: & - math_civita - use material, only: & - homogenization_maxNgrains,& - homogenization_Ngrains - use numerics, only: & - xSmoo_RGC - - implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen !< stress-like penalty - real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients - real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el,instance - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim - real(pReal), dimension (3,3) :: gDef,nDef - real(pReal), dimension (3) :: nVect,surfCorr - real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l - real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb - - type(tParameters) :: prm - integer(pInt), parameter :: nFace = 6_pInt - real(pReal), parameter :: nDefToler = 1.0e-10_pReal - nGDim = param(instance)%Nconstituents - rPen = 0.0_pReal - nMis = 0.0_pReal - -!-------------------------------------------------------------------------------------------------- -! get the correction factor the modulus of penalty stress representing the evolution of area of -! the interfaces due to deformations - surfCorr = surfaceCorrection(avgF,ip,el) - - associate(prm => param(instance)) -!-------------------------------------------------------------------------------------------------- -! debugging the surface correction factor - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el - write(6,'(1x,3(e11.4,1x))')(surfCorr(i), i = 1,3) - !$OMP END CRITICAL (write2out) - endif - -!-------------------------------------------------------------------------------------------------- -! computing the mismatch and penalty stress tensor of all grains - do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) - Gmoduli = equivalentModuli(iGrain,ip,el) - muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain - bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector - iGrain3 = grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position - -!* Looping over all six interfaces of each grain - do iFace = 1_pInt,nFace - intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain - nVect = interfaceNormal(intFace,ip,el) ! get the interface normal - iGNghb3 = iGrain3 ! identify the neighboring grain across the interface - iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) - if (iGNghb3(1) < 1) iGNghb3(1) = nGDim(1) ! with periodicity along e1 direction - if (iGNghb3(1) > nGDim(1)) iGNghb3(1) = 1_pInt - if (iGNghb3(2) < 1) iGNghb3(2) = nGDim(2) ! with periodicity along e2 direction - if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt - if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction - if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt - iGNghb = grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain - Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor - muGNghb = Gmoduli(1) - bgGNghb = Gmoduli(2) - gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! compute the difference/jump in deformation gradeint across the neighbor - -!-------------------------------------------------------------------------------------------------- -! compute the mismatch tensor of all interfaces - nDefNorm = 0.0_pReal - nDef = 0.0_pReal - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient - enddo; enddo - nDefNorm = nDefNorm + nDef(i,j)*nDef(i,j) ! compute the norm of the mismatch tensor - enddo; enddo - nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) - nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) - -!-------------------------------------------------------------------------------------------------- -! debuggin the mismatch tensor - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(nDef(i,j), j = 1,3) - enddo - write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm - !$OMP END CRITICAL (write2out) - endif - -!-------------------------------------------------------------------------------------------------- -! compute the stress penalty of all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & - *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & - *cosh(prm%ciAlpha*nDefNorm) & - *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & - *tanh(nDefNorm/xSmoo_RGC) - enddo; enddo - enddo; enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! debugging the stress-like penalty - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(rPen(i,j,iGrain), j = 1,3) - enddo - !$OMP END CRITICAL (write2out) - endif - - enddo - end associate - -end subroutine stressPenalty - - -!-------------------------------------------------------------------------------------------------- -!> @brief calculate stress-like penalty due to volume discrepancy -!-------------------------------------------------------------------------------------------------- -subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) - use debug, only: & - debug_level, & - debug_homogenization,& - debug_levelExtensive, & - debug_e, & - debug_i - use mesh, only: & - mesh_homogenizationAt - use math, only: & - math_det33, & - math_inv33 - use material, only: & - homogenization_maxNgrains,& - homogenization_Ngrains - use numerics, only: & - maxVolDiscr_RGC,& - volDiscrMod_RGC,& - volDiscrPow_RGC - - implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen ! stress-like penalty due to volume - real(pReal), intent(out) :: vDiscrep ! total volume discrepancy - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef ! deformation gradients - real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient - integer(pInt), intent(in) :: ip,& ! integration point - el - real(pReal), dimension (homogenization_maxNgrains) :: gVol - integer(pInt) :: iGrain,nGrain,i,j - - nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) - -!-------------------------------------------------------------------------------------------------- -! compute the volumes of grains and of cluster - vDiscrep = math_det33(fAvg) ! compute the volume of the cluster - do iGrain = 1_pInt,nGrain - gVol(iGrain) = math_det33(fDef(1:3,1:3,iGrain)) ! compute the volume of individual grains - vDiscrep = vDiscrep - gVol(iGrain)/real(nGrain,pReal) ! calculate the difference/dicrepancy between - ! the volume of the cluster and the the total volume of grains - enddo - -!-------------------------------------------------------------------------------------------------- -! calculate the stress and penalty due to volume discrepancy - vPen = 0.0_pReal - do iGrain = 1_pInt,nGrain - vPen(:,:,iGrain) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & - sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & - gVol(iGrain)*transpose(math_inv33(fDef(:,:,iGrain))) - -!-------------------------------------------------------------------------------------------------- -! debugging the stress-like penalty - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a30,i2)')'Volume penalty of grain: ',iGrain - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(vPen(i,j,iGrain), j = 1,3) - enddo - !$OMP END CRITICAL (write2out) - endif - enddo - -end subroutine volumePenalty - - -!-------------------------------------------------------------------------------------------------- -!> @brief compute the correction factor accouted for surface evolution (area change) due to -! deformation -!-------------------------------------------------------------------------------------------------- -function surfaceCorrection(avgF,ip,el) - use math, only: & - math_invert33, & - math_mul33x33 - - implicit none - real(pReal), dimension(3) :: surfaceCorrection - real(pReal), dimension(3,3), intent(in) :: avgF !< average F - integer(pInt), intent(in) :: ip,& !< integration point number - el !< element number - real(pReal), dimension(3,3) :: invC - real(pReal), dimension(3) :: nVect - real(pReal) :: detF - integer(pInt) :: i,j,iBase - logical :: error - - call math_invert33(math_mul33x33(transpose(avgF),avgF),invC,detF,error) - - surfaceCorrection = 0.0_pReal - do iBase = 1_pInt,3_pInt - nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],ip,el) ! get the normal of the interface - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal - enddo; enddo - surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) - enddo - -end function surfaceCorrection - - -!-------------------------------------------------------------------------------------------------- -!> @brief compute the equivalent shear and bulk moduli from the elasticity tensor -!-------------------------------------------------------------------------------------------------- -function equivalentModuli(grainID,ip,el) - use constitutive, only: & - constitutive_homogenizedC - - implicit none - integer(pInt), intent(in) :: & - grainID,& - ip, & !< integration point number - el !< element number - real(pReal), dimension (6,6) :: elasTens - real(pReal), dimension(2) :: equivalentModuli - real(pReal) :: & - cEquiv_11, & - cEquiv_12, & - cEquiv_44 - - elasTens = constitutive_homogenizedC(grainID,ip,el) - -!-------------------------------------------------------------------------------------------------- -! compute the equivalent shear modulus after Turterltaub and Suiker, JMPS (2005) - cEquiv_11 = (elasTens(1,1) + elasTens(2,2) + elasTens(3,3))/3.0_pReal - cEquiv_12 = (elasTens(1,2) + elasTens(2,3) + elasTens(3,1) + & - elasTens(1,3) + elasTens(2,1) + elasTens(3,2))/6.0_pReal - cEquiv_44 = (elasTens(4,4) + elasTens(5,5) + elasTens(6,6))/3.0_pReal - equivalentModuli(1) = 0.2_pReal*(cEquiv_11 - cEquiv_12) + 0.6_pReal*cEquiv_44 - -!-------------------------------------------------------------------------------------------------- -! obtain the length of Burgers vector (could be model dependend) - equivalentModuli(2) = 2.5e-10_pReal - -end function equivalentModuli !-------------------------------------------------------------------------------------------------- @@ -1394,44 +1433,4 @@ pure function interface1to4(iFace1D, instance) end function interface1to4 -!-------------------------------------------------------------------------------------------------- -!> @brief calculating the grain deformation gradient (the same with -! homogenization_RGC_partionDeformation, but used only for perturbation scheme) -!-------------------------------------------------------------------------------------------------- -subroutine grainDeformation(F, avgF, ip, el) - use mesh, only: & - mesh_homogenizationAt - use material, only: & - homogenization_maxNgrains,& - homogenization_typeInstance - - implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain - real(pReal), dimension (3,3), intent(in) :: avgF !< - integer(pInt), intent(in) :: & - el, & !< element number - ip !< integration point number - real(pReal), dimension (3) :: aVect,nVect - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: instance, iGrain,iFace,i,j - -!-------------------------------------------------------------------------------------------------- -! compute the deformation gradient of individual grains due to relaxations - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - F = 0.0_pReal - do iGrain = 1_pInt,product(param(instance)%Nconstituents) - iGrain3 = grain1to3(iGrain,instance) - do iFace = 1_pInt,6_pInt - intFace = getInterface(iFace,iGrain3) - aVect = relaxationVector(intFace,instance, ip, el) - nVect = interfaceNormal(intFace,ip,el) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & - F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations - enddo - F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient - enddo - -end subroutine grainDeformation - end module homogenization_RGC From 69079b65584052700e0a1edba7fcf8b25be9cd71 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 21:16:36 +0100 Subject: [PATCH 029/372] was not used at all --- src/homogenization_RGC.f90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 72d838c71..43bf9cea0 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -1105,8 +1105,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) - aVect = relaxationVector(intFace,instance, ip, el) - nVect = interfaceNormal(intFace,ip,el) + aVect = relaxationVector(intFace,instance, ip, el) + nVect = interfaceNormal(intFace,ip,el) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations enddo @@ -1219,7 +1219,6 @@ function relaxationVector(intFace,instance, ip, el) integer(pInt), intent(in) :: ip, el real(pReal), dimension (3) :: relaxationVector integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) - integer(pInt), dimension (3) :: nGDim integer(pInt) :: & iNum, & instance !< homogenization ID @@ -1227,7 +1226,6 @@ function relaxationVector(intFace,instance, ip, el) !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array relaxationVector = 0.0_pReal - nGDim = param(instance)%Nconstituents iNum = interface4to1(intFace,instance) ! identify the position of the interface in global state array if (iNum > 0_pInt) relaxationVector = homogState(mappingHomogenization(2,ip,el))% & state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries From 70998f7f9a2f5730c0ee0cce22b3d3535195f9c2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 21:36:49 +0100 Subject: [PATCH 030/372] cleaning --- src/homogenization_RGC.f90 | 139 ++++++++++++++++++------------------- 1 file changed, 67 insertions(+), 72 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 43bf9cea0..1fb26b1e8 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -48,25 +48,32 @@ module homogenization_RGC outputID !< ID of each post result output end type - type, private :: tRGCState + type, private :: tRGCstate real(pReal), pointer, dimension(:) :: & work, & penaltyEnergy, & volumeDiscrepancy, & relaxationRate_avg, & - relaxationRage_max + relaxationRate_max real(pReal), pointer, dimension(:,:) :: & mismatch - end type tRGCState + end type tRGCstate + + type, private :: tRGCdependentState + real(pReal), allocatable, dimension(:,:,:) :: & + orientation + end type tRGCdependentState + + type(tparameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) + type(tRGCstate), dimension(:), allocatable, private :: state + type(tRGCdependentState), dimension(:), allocatable, private :: dependentState + ! START: Could be improved real(pReal), dimension(:,:,:,:), allocatable, private :: & homogenization_RGC_orientation ! END: Could be improved - type(tParameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) - type(tRGCState), dimension(:), allocatable, private :: state - public :: & homogenization_RGC_init, & homogenization_RGC_partitionDeformation, & @@ -147,6 +154,7 @@ subroutine homogenization_RGC_init() allocate(param(maxNinstance)) ! one container of parameters per instance allocate(state(maxNinstance)) ! one container per instance + allocate(dependentState(maxNinstance)) ! one container per instance allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) @@ -201,24 +209,6 @@ subroutine homogenization_RGC_init() prm%outputID = [prm%outputID , outputID] endif enddo -!-------------------------------------------------------------------------------------------------- -! * assigning cluster orientations - elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then - noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then - homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) - do i = 2_pInt,mesh_NipsPerElem - homogenization_RGC_orientation(1:3,1:3,i,e) = merge(homogenization_RGC_orientation(1:3,1:3,1,e), & - math_EulerToR(math_sampleRandomOri()), & - microstructure_elemhomo(mesh_microstructureAt(e))) - enddo - else noOrientationGiven - do i = 1_pInt,mesh_NipsPerElem - homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(prm%angles*inRad) - enddo - endif noOrientationGiven - endif - enddo elementLooping if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then write(6,'(a15,1x,i4,/)') 'instance: ', instance @@ -244,9 +234,34 @@ subroutine homogenization_RGC_init() allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) - state(instance)%work =>homogState(h)%state(nIntFaceTot+1,:) - state(instance)%penaltyEnergy =>homogState(h)%state(nIntFaceTot+5,:) + state(instance)%work =>homogState(h)%state(nIntFaceTot+1,:) + state(instance)%mismatch =>homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) + state(instance)%penaltyEnergy =>homogState(h)%state(nIntFaceTot+5,:) + state(instance)%volumeDiscrepancy =>homogState(h)%state(nIntFaceTot+6,:) + state(instance)%relaxationRate_avg =>homogState(h)%state(nIntFaceTot+7,:) + state(instance)%relaxationRate_max =>homogState(h)%state(nIntFaceTot+8,:) + allocate(dependentState(instance)%orientation(3,3,NofMyHomog)) + + +!-------------------------------------------------------------------------------------------------- +! * assigning cluster orientations + elementLooping: do e = 1_pInt,mesh_NcpElems + if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then + noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then + homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) + do i = 2_pInt,mesh_NipsPerElem + homogenization_RGC_orientation(1:3,1:3,i,e) = merge(homogenization_RGC_orientation(1:3,1:3,1,e), & + math_EulerToR(math_sampleRandomOri()), & + microstructure_elemhomo(mesh_microstructureAt(e))) + enddo + else noOrientationGiven + do i = 1_pInt,mesh_NipsPerElem + homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(prm%angles*inRad) + enddo + endif noOrientationGiven + endif + enddo elementLooping end associate enddo @@ -278,7 +293,6 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 integer(pInt) :: instance, iGrain,iFace,i,j - integer(pInt), parameter :: nFace = 6_pInt !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations @@ -286,7 +300,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) iGrain3 = grain1to3(iGrain,instance) - do iFace = 1_pInt,nFace + do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain aVect = relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array nVect = interfaceNormal(intFace,ip,el) ! get the normal of each interface @@ -371,8 +385,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal) :: residMax,stresMax,volDiscrep logical error - integer(pInt), parameter :: nFace = 6_pInt - real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax @@ -527,32 +539,25 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo enddo enddo - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+2,of) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+3,of) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+4,of) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction + state(instance)%mismatch(1,of) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction + state(instance)%mismatch(2,of) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction + state(instance)%mismatch(3,of) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+6,of) = volDiscrep ! the overall volume discrepancy - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+7,of) = & - sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) ! the average rate of relaxation vectors - homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+8,of) = maxval(abs(drelax))/dt ! the maximum rate of relaxation vectors + state(instance)%volumeDiscrepancy(of) = volDiscrep + state(instance)%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + state(instance)%relaxationRate_max(of) = maxval(abs(drelax))/dt if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',state(instance)%work(of) - write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',sum(NN(1,:))/real(nGrain,pReal), & - sum(NN(2,:))/real(nGrain,pReal), & - sum(NN(3,:))/real(nGrain,pReal) - write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ',state(instance)%penaltyEnergy(of) - write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ',volDiscrep - write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ',maxval(abs(drelax))/dt - write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ',sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',state(instance)%mismatch(1,of), & + state(instance)%mismatch(2,of), & + state(instance)%mismatch(3,of) + write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ', state(instance)%penaltyEnergy(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ', state(instance)%volumeDiscrepancy(of) + write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ', state(instance)%relaxationRate_max(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ', state(instance)%relaxationRate_avg(of) flush(6) !$OMP END CRITICAL (write2out) endif @@ -600,7 +605,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGrN = grain3to1(iGr3N,instance) ! translate into global grain ID intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = interfaceNormal(intFaceN,ip,el) ! get the interface normal - do iFace = 1_pInt,nFace + do iFace = 1_pInt,6_pInt intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces iMun = interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index @@ -620,7 +625,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGrP = grain3to1(iGr3P,instance) ! translate into global grain ID intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system normP = interfaceNormal(intFaceP,ip,el) ! get the interface normal - do iFace = 1_pInt,nFace + do iFace = 1_pInt,6_pInt intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces iMun = interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index @@ -831,7 +836,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb type(tParameters) :: prm - integer(pInt), parameter :: nFace = 6_pInt real(pReal), parameter :: nDefToler = 1.0e-10_pReal nGDim = param(instance)%Nconstituents @@ -863,17 +867,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGrain3 = grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position !* Looping over all six interfaces of each grain - do iFace = 1_pInt,nFace + do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain nVect = interfaceNormal(intFace,ip,el) ! get the interface normal iGNghb3 = iGrain3 ! identify the neighboring grain across the interface - iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) - if (iGNghb3(1) < 1) iGNghb3(1) = nGDim(1) ! with periodicity along e1 direction - if (iGNghb3(1) > nGDim(1)) iGNghb3(1) = 1_pInt - if (iGNghb3(2) < 1) iGNghb3(2) = nGDim(2) ! with periodicity along e2 direction - if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt - if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction - if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt + iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & + + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) + where(iGNghb3 < 1) iGNghb3 = nGDim + where(iGNghb3 >nGDim) iGNghb3 = 1_pInt iGNghb = grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) @@ -1001,10 +1002,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !$OMP END CRITICAL (write2out) endif enddo - + end subroutine volumePenalty - - + + !-------------------------------------------------------------------------------------------------- !> @brief compute the correction factor accouted for surface evolution (area change) due to ! deformation @@ -1037,8 +1038,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo end function surfaceCorrection - - + + !-------------------------------------------------------------------------------------------------- !> @brief compute the equivalent shear and bulk moduli from the elasticity tensor !-------------------------------------------------------------------------------------------------- @@ -1204,9 +1205,6 @@ pure function homogenization_RGC_postResults(ip,el) result(postResults) end function homogenization_RGC_postResults - - - !-------------------------------------------------------------------------------------------------- !> @brief collect relaxation vectors of an interface !-------------------------------------------------------------------------------------------------- @@ -1237,9 +1235,6 @@ end function relaxationVector !> @brief identify the normal of an interface !-------------------------------------------------------------------------------------------------- function interfaceNormal(intFace,ip,el) - use debug, only: & - debug_homogenization,& - debug_levelExtensive use math, only: & math_mul33x3 From 078729bfa31084cb73c891c468e940cdb6bff067 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 22:43:52 +0100 Subject: [PATCH 031/372] using dependent state --- src/homogenization_RGC.f90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 1fb26b1e8..cdb0ed1bc 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -68,12 +68,6 @@ module homogenization_RGC type(tRGCstate), dimension(:), allocatable, private :: state type(tRGCdependentState), dimension(:), allocatable, private :: dependentState - -! START: Could be improved - real(pReal), dimension(:,:,:,:), allocatable, private :: & - homogenization_RGC_orientation -! END: Could be improved - public :: & homogenization_RGC_init, & homogenization_RGC_partitionDeformation, & @@ -131,7 +125,7 @@ subroutine homogenization_RGC_init() outputSize, & instance, & sizeHState, nIntFaceTot - integer(pInt) :: maxNinstance, i,j,e, mySize + integer(pInt) :: maxNinstance, i,j,e, mySize, of character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & outputID !< ID of each post result output @@ -161,7 +155,6 @@ subroutine homogenization_RGC_init() homogenization_RGC_output='' allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& source=0_pInt) - allocate(homogenization_RGC_orientation(3,3,mesh_NipsPerElem,mesh_NcpElems), source=0.0_pReal) do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle @@ -248,16 +241,17 @@ subroutine homogenization_RGC_init() ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then + of = mappingHomogenization(1,1,e) noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then - homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) + dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(math_sampleRandomOri()) do i = 2_pInt,mesh_NipsPerElem - homogenization_RGC_orientation(1:3,1:3,i,e) = merge(homogenization_RGC_orientation(1:3,1:3,1,e), & + dependentState(instance)%orientation(1:3,1:3,of) = merge(dependentState(instance)%orientation(1:3,1:3,of), & math_EulerToR(math_sampleRandomOri()), & microstructure_elemhomo(mesh_microstructureAt(e))) enddo else noOrientationGiven do i = 1_pInt,mesh_NipsPerElem - homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(prm%angles*inRad) + dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) enddo endif noOrientationGiven endif @@ -1237,6 +1231,8 @@ end function relaxationVector function interfaceNormal(intFace,ip,el) use math, only: & math_mul33x3 + use material, only: & + mappingHomogenization implicit none real(pReal), dimension (3) :: interfaceNormal @@ -1244,7 +1240,7 @@ function interfaceNormal(intFace,ip,el) integer(pInt), intent(in) :: & ip, & !< integration point number el !< element number - integer(pInt) :: nPos + integer(pInt) :: nPos,instance,of !-------------------------------------------------------------------------------------------------- ! get the normal of the interface, identified from the value of intFace(1) @@ -1252,8 +1248,10 @@ function interfaceNormal(intFace,ip,el) 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 + of = mappingHomogenization(1,ip,el) + instance = mappingHomogenization(2,ip,el) interfaceNormal = & - math_mul33x3(homogenization_RGC_orientation(1:3,1:3,ip,el),interfaceNormal) + math_mul33x3(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) end function interfaceNormal From 8127d85be182a58368a2ec4a08a5b23c74480c14 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 23:13:20 +0100 Subject: [PATCH 032/372] simplifying --- src/homogenization_RGC.f90 | 128 +++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 63 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index cdb0ed1bc..78285d33a 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -56,6 +56,7 @@ module homogenization_RGC relaxationRate_avg, & relaxationRate_max real(pReal), pointer, dimension(:,:) :: & + relaxationVector, & mismatch end type tRGCstate @@ -227,12 +228,13 @@ subroutine homogenization_RGC_init() allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) - state(instance)%work =>homogState(h)%state(nIntFaceTot+1,:) - state(instance)%mismatch =>homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) - state(instance)%penaltyEnergy =>homogState(h)%state(nIntFaceTot+5,:) - state(instance)%volumeDiscrepancy =>homogState(h)%state(nIntFaceTot+6,:) - state(instance)%relaxationRate_avg =>homogState(h)%state(nIntFaceTot+7,:) - state(instance)%relaxationRate_max =>homogState(h)%state(nIntFaceTot+8,:) + state(instance)%relaxationVector => homogState(h)%state(1:nIntFaceTot,:) + state(instance)%work => homogState(h)%state(nIntFaceTot+1,:) + state(instance)%mismatch => homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) + state(instance)%penaltyEnergy => homogState(h)%state(nIntFaceTot+5,:) + state(instance)%volumeDiscrepancy => homogState(h)%state(nIntFaceTot+6,:) + state(instance)%relaxationRate_avg => homogState(h)%state(nIntFaceTot+7,:) + state(instance)%relaxationRate_max => homogState(h)%state(nIntFaceTot+8,:) allocate(dependentState(instance)%orientation(3,3,NofMyHomog)) @@ -241,16 +243,18 @@ subroutine homogenization_RGC_init() ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then - of = mappingHomogenization(1,1,e) noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then + of = mappingHomogenization(1,1,e) dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(math_sampleRandomOri()) do i = 2_pInt,mesh_NipsPerElem + of = mappingHomogenization(1,i,e) dependentState(instance)%orientation(1:3,1:3,of) = merge(dependentState(instance)%orientation(1:3,1:3,of), & math_EulerToR(math_sampleRandomOri()), & microstructure_elemhomo(mesh_microstructureAt(e))) enddo else noOrientationGiven do i = 1_pInt,mesh_NipsPerElem + of = mappingHomogenization(1,i,e) dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) enddo endif noOrientationGiven @@ -273,6 +277,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) use mesh, only: & mesh_homogenizationAt use material, only: & + mappingHomogenization, & homogenization_maxNgrains, & homogenization_Ngrains,& homogenization_typeInstance @@ -286,18 +291,21 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: instance, iGrain,iFace,i,j + integer(pInt) :: instance, iGrain,iFace,i,j,of + type(tParameters) :: prm !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations instance = homogenization_typeInstance(mesh_homogenizationAt(el)) + of = mappingHomogenization(1,ip,el) + associate(prm => param(instance)) F = 0.0_pReal do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,6_pInt - intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain - aVect = relaxationVector(intFace,instance, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array - nVect = interfaceNormal(intFace,ip,el) ! get the normal of each interface + intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain + aVect = relaxationVector(intFace,instance,of) ! get the relaxation vectors for each interface from global relaxation vector array + nVect = interfaceNormal(intFace,instance,of) forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation enddo @@ -317,6 +325,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) endif enddo + end associate end subroutine homogenization_RGC_partitionDeformation @@ -451,7 +460,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = getInterface(2_pInt*faceID(1),iGr3N) - normN = interfaceNormal(intFaceN,ip,el) ! get the interface normal + normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) @@ -459,7 +468,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) - normP = interfaceNormal(intFaceP,ip,el) ! get the interface normal + normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual of traction at the interface (in local system, 4-dimensional index) @@ -598,10 +607,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem iGrN = grain3to1(iGr3N,instance) ! translate into global grain ID intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system - normN = interfaceNormal(intFaceN,ip,el) ! get the interface normal + normN = interfaceNormal(intFaceN,instance,of) do iFace = 1_pInt,6_pInt intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface - mornN = interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces + mornN = interfaceNormal(intFaceN,instance,of) iMun = interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt @@ -618,10 +627,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem iGrP = grain3to1(iGr3P,instance) ! translate into global grain ID intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system - normP = interfaceNormal(intFaceP,ip,el) ! get the interface normal + normP = interfaceNormal(intFaceP,instance,of) do iFace = 1_pInt,6_pInt intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface - mornP = interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces + mornP = interfaceNormal(intFaceP,instance,of) iMun = interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt @@ -669,7 +678,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain - normN = interfaceNormal(intFaceN,ip,el) ! get the corresponding interface normal + normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) @@ -677,7 +686,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain - normP = interfaceNormal(intFaceP,ip,el) ! get the corresponding normal + normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state @@ -810,8 +819,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) use math, only: & math_civita use material, only: & - homogenization_maxNgrains,& - homogenization_Ngrains + homogenization_maxNgrains use numerics, only: & xSmoo_RGC @@ -826,7 +834,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (3,3) :: gDef,nDef real(pReal), dimension (3) :: nVect,surfCorr real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l + integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l,of real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb type(tParameters) :: prm @@ -839,8 +847,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! get the correction factor the modulus of penalty stress representing the evolution of area of ! the interfaces due to deformations - surfCorr = surfaceCorrection(avgF,ip,el) - + + of = mappingHomogenization(1,ip,el) + surfCorr = surfaceCorrection(avgF,instance,of) associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! debugging the surface correction factor @@ -854,7 +863,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) + do iGrain = 1_pInt,product(param(instance)%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector @@ -863,7 +872,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !* Looping over all six interfaces of each grain do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain - nVect = interfaceNormal(intFace,ip,el) ! get the interface normal + nVect = interfaceNormal(intFace,instance,of) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) @@ -1004,7 +1013,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !> @brief compute the correction factor accouted for surface evolution (area change) due to ! deformation !-------------------------------------------------------------------------------------------------- - function surfaceCorrection(avgF,ip,el) + function surfaceCorrection(avgF,instance,of) use math, only: & math_invert33, & math_mul33x33 @@ -1012,8 +1021,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension(3) :: surfaceCorrection real(pReal), dimension(3,3), intent(in) :: avgF !< average F - integer(pInt), intent(in) :: ip,& !< integration point number - el !< element number + integer(pInt), intent(in) :: & + instance, & + of real(pReal), dimension(3,3) :: invC real(pReal), dimension(3) :: nVect real(pReal) :: detF @@ -1024,7 +1034,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) surfaceCorrection = 0.0_pReal do iBase = 1_pInt,3_pInt - nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],ip,el) ! get the normal of the interface + nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],instance,of) do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal enddo; enddo @@ -1090,24 +1100,25 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: instance, iGrain,iFace,i,j + integer(pInt) :: instance, iGrain,iFace,i,j,of - !-------------------------------------------------------------------------------------------------- - ! compute the deformation gradient of individual grains due to relaxations + !-------------------------------------------------------------------------------------------------- + ! compute the deformation gradient of individual grains due to relaxations instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - F = 0.0_pReal - do iGrain = 1_pInt,product(param(instance)%Nconstituents) - iGrain3 = grain1to3(iGrain,instance) - do iFace = 1_pInt,6_pInt - intFace = getInterface(iFace,iGrain3) - aVect = relaxationVector(intFace,instance, ip, el) - nVect = interfaceNormal(intFace,ip,el) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & - F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations - enddo - F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient - enddo - + of = mappingHomogenization(1,ip,el) + F = 0.0_pReal + do iGrain = 1_pInt,product(param(instance)%Nconstituents) + iGrain3 = grain1to3(iGrain,instance) + do iFace = 1_pInt,6_pInt + intFace = getInterface(iFace,iGrain3) + aVect = relaxationVector(intFace,instance,of) + nVect = interfaceNormal(intFace,ip,el) + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations + enddo + F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient + enddo + end subroutine grainDeformation end function homogenization_RGC_updateState @@ -1202,25 +1213,20 @@ end function homogenization_RGC_postResults !-------------------------------------------------------------------------------------------------- !> @brief collect relaxation vectors of an interface !-------------------------------------------------------------------------------------------------- -function relaxationVector(intFace,instance, ip, el) - use material, only: & - homogState, & - mappingHomogenization +function relaxationVector(intFace,instance,of) implicit none - integer(pInt), intent(in) :: ip, el + integer(pInt), intent(in) :: instance,of real(pReal), dimension (3) :: relaxationVector integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) integer(pInt) :: & - iNum, & - instance !< homogenization ID + iNum !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array relaxationVector = 0.0_pReal iNum = interface4to1(intFace,instance) ! identify the position of the interface in global state array - if (iNum > 0_pInt) relaxationVector = homogState(mappingHomogenization(2,ip,el))% & - state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries + if (iNum > 0_pInt) relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) end function relaxationVector @@ -1228,19 +1234,17 @@ end function relaxationVector !-------------------------------------------------------------------------------------------------- !> @brief identify the normal of an interface !-------------------------------------------------------------------------------------------------- -function interfaceNormal(intFace,ip,el) +function interfaceNormal(intFace,instance,of) use math, only: & math_mul33x3 - use material, only: & - mappingHomogenization implicit none real(pReal), dimension (3) :: interfaceNormal integer(pInt), dimension (4), intent(in) :: intFace !< interface ID in 4D array (normal and position) integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - integer(pInt) :: nPos,instance,of + instance, & + of + integer(pInt) :: nPos !-------------------------------------------------------------------------------------------------- ! get the normal of the interface, identified from the value of intFace(1) @@ -1248,8 +1252,6 @@ function interfaceNormal(intFace,ip,el) 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 - of = mappingHomogenization(1,ip,el) - instance = mappingHomogenization(2,ip,el) interfaceNormal = & math_mul33x3(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) From 3c11905f635118bb25ee8d9a6e2aa30bdac5685d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Nov 2018 23:23:52 +0100 Subject: [PATCH 033/372] cleaning --- src/homogenization.f90 | 5 +- src/homogenization_RGC.f90 | 103 +++++++++++++------------------------ 2 files changed, 41 insertions(+), 67 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 708e72fa8..9e40150d9 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -911,6 +911,7 @@ subroutine homogenization_partitionDeformation(ip,el) use mesh, only: & mesh_element use material, only: & + mappingHomogenization, & homogenization_type, & homogenization_maxNgrains, & homogenization_typeInstance, & @@ -929,7 +930,7 @@ subroutine homogenization_partitionDeformation(ip,el) ip, & !< integration point el !< element number integer(pInt) :: & - instance + instance, of chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) @@ -946,6 +947,8 @@ subroutine homogenization_partitionDeformation(ip,el) instance) case (HOMOGENIZATION_RGC_ID) chosenHomogenization + instance = homogenization_typeInstance(mesh_element(3,el)) + of = mappingHomogenization(1,ip,el) call homogenization_RGC_partitionDeformation(& crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & materialpoint_subF(1:3,1:3,ip,el),& diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 78285d33a..bf136d36e 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -269,38 +269,31 @@ end subroutine homogenization_RGC_init !-------------------------------------------------------------------------------------------------- !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- -subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) +subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) use debug, only: & debug_level, & debug_homogenization, & debug_levelExtensive - use mesh, only: & - mesh_homogenizationAt use material, only: & - mappingHomogenization, & - homogenization_maxNgrains, & - homogenization_Ngrains,& - homogenization_typeInstance + homogenization_maxNgrains implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number + instance, & + of !< element number real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: instance, iGrain,iFace,i,j,of + integer(pInt) :: iGrain,iFace,i,j type(tParameters) :: prm !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - of = mappingHomogenization(1,ip,el) associate(prm => param(instance)) F = 0.0_pReal - do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) + do iGrain = 1_pInt,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,instance) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain @@ -532,20 +525,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) ! time-integration loop for the calculating the work and energy - do i = 1_pInt,3_pInt - do j = 1_pInt,3_pInt + do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) ! time-integration loop for work and energy + do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt state(instance)%work(of) = state(instance)%work(of) & + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) state(instance)%penaltyEnergy(of) = state(instance)%penaltyEnergy(of) & + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) - enddo - enddo + enddo; enddo enddo - state(instance)%mismatch(1,of) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction - state(instance)%mismatch(2,of) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction - state(instance)%mismatch(3,of) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction + state(instance)%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) ! the overall mismatch of all interface normals state(instance)%volumeDiscrepancy(of) = volDiscrep state(instance)%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) state(instance)%relaxationRate_max(of) = maxval(abs(drelax))/dt @@ -614,7 +603,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iMun = interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt - smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) + smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) enddo;enddo;enddo;enddo ! projecting the material tangent dPdF into the interface ! to obtain the Jacobian matrix contribution of dPdF @@ -839,6 +829,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) type(tParameters) :: prm real(pReal), parameter :: nDefToler = 1.0e-10_pReal + logical :: debugActive + + debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip nGDim = param(instance)%Nconstituents rPen = 0.0_pReal @@ -851,14 +845,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) of = mappingHomogenization(1,ip,el) surfCorr = surfaceCorrection(avgF,instance,of) associate(prm => param(instance)) - !-------------------------------------------------------------------------------------------------- - ! debugging the surface correction factor - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el - write(6,'(1x,3(e11.4,1x))')(surfCorr(i), i = 1,3) - !$OMP END CRITICAL (write2out) + + if (debugActive) then + write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el + write(6,*) surfCorr endif !-------------------------------------------------------------------------------------------------- @@ -892,22 +882,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient enddo; enddo - nDefNorm = nDefNorm + nDef(i,j)*nDef(i,j) ! compute the norm of the mismatch tensor + nDefNorm = nDefNorm + nDef(i,j)**2.0_pReal ! compute the norm of the mismatch tensor enddo; enddo nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) - !-------------------------------------------------------------------------------------------------- - ! debuggin the mismatch tensor - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) + if (debugActive) then write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(nDef(i,j), j = 1,3) - enddo - write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm - !$OMP END CRITICAL (write2out) + write(6,*) transpose(nDef) + write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm endif !-------------------------------------------------------------------------------------------------- @@ -923,16 +906,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo; enddo enddo - !-------------------------------------------------------------------------------------------------- - ! debugging the stress-like penalty - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(rPen(i,j,iGrain), j = 1,3) - enddo - !$OMP END CRITICAL (write2out) + if (debugActive) then + write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain + write(6,*) transpose(rPen(1:3,1:3,iGrain)) endif enddo @@ -972,10 +948,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), intent(in) :: ip,& ! integration point el real(pReal), dimension (homogenization_maxNgrains) :: gVol - integer(pInt) :: iGrain,nGrain,i,j - + integer(pInt) :: iGrain,nGrain + logical :: debugActive + + debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip + nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) - + !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster vDiscrep = math_det33(fAvg) ! compute the volume of the cluster @@ -993,16 +973,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & gVol(iGrain)*transpose(math_inv33(fDef(:,:,iGrain))) - !-------------------------------------------------------------------------------------------------- - ! debugging the stress-like penalty - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) + if (debugActive) then write(6,'(1x,a30,i2)')'Volume penalty of grain: ',iGrain - do i = 1,3 - write(6,'(1x,3(e11.4,1x))')(vPen(i,j,iGrain), j = 1,3) - enddo - !$OMP END CRITICAL (write2out) + write(6,*) transpose(vPen(:,:,iGrain)) endif enddo @@ -1252,9 +1225,7 @@ 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 = math_mul33x3(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) end function interfaceNormal From f471911e018de0443121e4b6589e5eab88b55c97 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 07:27:25 +0100 Subject: [PATCH 034/372] fixed array out of bounds during initialization happened for inactive homogenization --- src/homogenization_RGC.f90 | 43 +++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 24 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index bf136d36e..ad217bed2 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -242,7 +242,7 @@ subroutine homogenization_RGC_init() !-------------------------------------------------------------------------------------------------- ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance) then + if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance .and. NofMyHomog > 0_pInt) then noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then of = mappingHomogenization(1,1,e) dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(math_sampleRandomOri()) @@ -653,7 +653,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = p_relax - call grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state + call grainDeformation(pF,avgF,instance,of) ! compute the grains deformation from perturbed state call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state @@ -1057,40 +1057,35 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !> @brief calculating the grain deformation gradient (the same with ! homogenization_RGC_partionDeformation, but used only for perturbation scheme) !-------------------------------------------------------------------------------------------------- - subroutine grainDeformation(F, avgF, ip, el) - use mesh, only: & - mesh_homogenizationAt + subroutine grainDeformation(F, avgF, instance, of) use material, only: & - homogenization_maxNgrains,& - homogenization_typeInstance + homogenization_maxNgrains implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain real(pReal), dimension (3,3), intent(in) :: avgF !< integer(pInt), intent(in) :: & - el, & !< element number - ip !< integration point number + instance, & + of real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: instance, iGrain,iFace,i,j,of + integer(pInt) :: iGrain,iFace,i,j !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) - of = mappingHomogenization(1,ip,el) - F = 0.0_pReal - do iGrain = 1_pInt,product(param(instance)%Nconstituents) - iGrain3 = grain1to3(iGrain,instance) - do iFace = 1_pInt,6_pInt - intFace = getInterface(iFace,iGrain3) - aVect = relaxationVector(intFace,instance,of) - nVect = interfaceNormal(intFace,ip,el) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & - F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations - enddo - F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient - enddo + F = 0.0_pReal + do iGrain = 1_pInt,product(param(instance)%Nconstituents) + iGrain3 = grain1to3(iGrain,instance) + do iFace = 1_pInt,6_pInt + intFace = getInterface(iFace,iGrain3) + aVect = relaxationVector(intFace,instance,of) + nVect = interfaceNormal(intFace,instance,of) + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations + enddo + F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient + enddo end subroutine grainDeformation From 4dc3761feadf82ac4511765b7de44620830c4878 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 07:29:39 +0100 Subject: [PATCH 035/372] setting of (random) cluster orientations remove can be easily done in a pre processing step --- src/homogenization_RGC.f90 | 20 ++++---------------- 1 file changed, 4 insertions(+), 16 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index ad217bed2..502baf380 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -168,8 +168,7 @@ subroutine homogenization_RGC_init() prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') prm%dAlpha = config_homogenization(h)%getFloats('grainsize',requiredShape=[3]) - prm%angles = config_homogenization(h)%getFloats('clusterorientation',requiredShape=[3],& - defaultVal=[400.0_pReal,400.0_pReal,400.0_pReal]) + prm%angles = config_homogenization(h)%getFloats('clusterorientation',requiredShape=[3]) outputs = config_homogenization(h)%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) @@ -243,21 +242,10 @@ subroutine homogenization_RGC_init() ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance .and. NofMyHomog > 0_pInt) then - noOrientationGiven: if (all (prm%angles >= 399.9_pReal)) then - of = mappingHomogenization(1,1,e) - dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(math_sampleRandomOri()) - do i = 2_pInt,mesh_NipsPerElem + do i = 1_pInt,mesh_NipsPerElem of = mappingHomogenization(1,i,e) - dependentState(instance)%orientation(1:3,1:3,of) = merge(dependentState(instance)%orientation(1:3,1:3,of), & - math_EulerToR(math_sampleRandomOri()), & - microstructure_elemhomo(mesh_microstructureAt(e))) - enddo - else noOrientationGiven - do i = 1_pInt,mesh_NipsPerElem - of = mappingHomogenization(1,i,e) - dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) - enddo - endif noOrientationGiven + dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) + enddo endif enddo elementLooping end associate From 572576cf88cfcc90c5d730b5e732b0a73030dcd1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 07:33:57 +0100 Subject: [PATCH 036/372] these functions have no side effects --- src/homogenization_RGC.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 502baf380..2495750a4 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -1169,7 +1169,7 @@ end function homogenization_RGC_postResults !-------------------------------------------------------------------------------------------------- !> @brief collect relaxation vectors of an interface !-------------------------------------------------------------------------------------------------- -function relaxationVector(intFace,instance,of) +pure function relaxationVector(intFace,instance,of) implicit none integer(pInt), intent(in) :: instance,of @@ -1190,7 +1190,7 @@ end function relaxationVector !-------------------------------------------------------------------------------------------------- !> @brief identify the normal of an interface !-------------------------------------------------------------------------------------------------- -function interfaceNormal(intFace,instance,of) +pure function interfaceNormal(intFace,instance,of) use math, only: & math_mul33x3 @@ -1216,7 +1216,7 @@ end function interfaceNormal !-------------------------------------------------------------------------------------------------- !> @brief collect six faces of a grain in 4D (normal and position) !-------------------------------------------------------------------------------------------------- -function getInterface(iFace,iGrain3) +pure function getInterface(iFace,iGrain3) implicit none integer(pInt), dimension (4) :: getInterface @@ -1231,15 +1231,14 @@ function getInterface(iFace,iGrain3) !-------------------------------------------------------------------------------------------------- ! identify the interface position by the direction of its normal getInterface(2:4) = iGrain3 - if (iDir < 0_pInt) & ! to have a correlation with coordinate/position in real space - getInterface(1_pInt-iDir) = getInterface(1_pInt-iDir)-1_pInt + if (iDir < 0_pInt) getInterface(1_pInt-iDir) = getInterface(1_pInt-iDir)-1_pInt ! to have a correlation with coordinate/position in real space end function getInterface !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 1D (global array) to in 3D (local position) !-------------------------------------------------------------------------------------------------- -function grain1to3(grain1,instance) +pure function grain1to3(grain1,instance) implicit none integer(pInt), dimension (3) :: grain1to3 From ff2b693f1eb841be7f978e7e7adb8ed5befae5b3 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 07:56:27 +0100 Subject: [PATCH 037/372] simplified --- src/homogenization_RGC.f90 | 59 +++++++++++++------------------------- 1 file changed, 20 insertions(+), 39 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 2495750a4..de36df323 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -588,7 +588,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do iFace = 1_pInt,6_pInt intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = interfaceNormal(intFaceN,instance,of) - iMun = interface4to1(intFaceN,instance) ! translate the interfaces ID into local 4-dimensional index + iMun = interface4to1(intFaceN,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & @@ -609,7 +609,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do iFace = 1_pInt,6_pInt intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = interfaceNormal(intFaceP,instance,of) - iMun = interface4to1(intFaceP,instance) ! translate the interfaces ID into local 4-dimensional index + iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) @@ -1109,56 +1109,43 @@ pure function homogenization_RGC_postResults(ip,el) result(postResults) use material, only: & homogenization_typeInstance,& homogState, & - mappingHomogenization, & - homogenization_Noutput + mappingHomogenization implicit none integer(pInt), intent(in) :: & ip, & !< integration point number el !< element number - integer(pInt) instance,o,c,nIntFaceTot + integer(pInt) instance,o,c,of type(tParameters) :: prm real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_homogenizationAt(el)))) :: & postResults instance = homogenization_typeInstance(mesh_homogenizationAt(el)) associate(prm => param(instance)) - nIntFaceTot=(prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)* prm%Nconstituents(3)& - + prm%Nconstituents(1)* (prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3)& - + prm%Nconstituents(1)* prm%Nconstituents(2)* (prm%Nconstituents(3)-1_pInt) + of = mappingHomogenization(1,ip,el) c = 0_pInt postResults = 0.0_pReal outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) case (constitutivework_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) + postResults(c+1) = state(instance)%work(of) c = c + 1_pInt case (magnitudemismatch_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+2,mappingHomogenization(1,ip,el)) - postResults(c+2) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+3,mappingHomogenization(1,ip,el)) - postResults(c+3) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+4,mappingHomogenization(1,ip,el)) + postResults(c+1:c+3) = state(instance)%mismatch(1:3,of) c = c + 3_pInt case (penaltyenergy_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) + postResults(c+1) = state(instance)%penaltyEnergy(of) c = c + 1_pInt case (volumediscrepancy_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+6,mappingHomogenization(1,ip,el)) + postResults(c+1) = state(instance)%volumeDiscrepancy(of) c = c + 1_pInt case (averagerelaxrate_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+7,mappingHomogenization(1,ip,el)) + postResults(c+1) = state(instance)%relaxationrate_avg(of) c = c + 1_pInt case (maximumrelaxrate_ID) - postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & - state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) + postResults(c+1) = state(instance)%relaxationrate_max(of) c = c + 1_pInt end select enddo outputsLoop @@ -1181,7 +1168,7 @@ pure function relaxationVector(intFace,instance,of) !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array relaxationVector = 0.0_pReal - iNum = interface4to1(intFace,instance) ! identify the position of the interface in global state array + iNum = interface4to1(intFace,param(instance)%Nconstituents) ! identify the position of the interface in global state array if (iNum > 0_pInt) relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) end function relaxationVector @@ -1275,20 +1262,11 @@ end function grain3to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 4D (normal and local position) into 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function interface4to1(iFace4D, instance) +integer(pInt) pure function interface4to1(iFace4D, nGDim) implicit none - integer(pInt), dimension (4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) - integer(pInt), intent(in) :: instance - integer(pInt), dimension (3) :: nGDim,nIntFace - - nGDim = param(instance)%Nconstituents - -!-------------------------------------------------------------------------------------------------- -! compute the total number of interfaces, which ... - nIntFace(1) = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! ... normal //e1 - nIntFace(2) = nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! ... normal //e2 - nIntFace(3) = nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) ! ... normal //e3 + integer(pInt), dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) + integer(pInt), dimension(3), intent(in) :: nGDim interface4to1 = -1_pInt @@ -1300,11 +1278,14 @@ integer(pInt) pure function interface4to1(iFace4D, instance) if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 2_pInt) then ! interface with normal //e2 interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & - + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) + nIntFace(1) + + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) & + + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) interface4to1 = 0_pInt elseif (abs(iFace4D(1)) == 3_pInt) then ! interface with normal //e3 interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & - + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) + nIntFace(1) + nIntFace(2) + + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) & + + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 + + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! total number of interfaces normal //e2 if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) interface4to1 = 0_pInt endif From 78f4d4c5ee12891922dbe542da967865208a6020 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 08:11:35 +0100 Subject: [PATCH 038/372] simplified --- src/homogenization_RGC.f90 | 66 ++++++++++++++++++-------------------- 1 file changed, 31 insertions(+), 35 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index de36df323..f1652f79b 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -282,7 +282,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) associate(prm => param(instance)) F = 0.0_pReal do iGrain = 1_pInt,product(prm%Nconstituents) - iGrain3 = grain1to3(iGrain,instance) + iGrain3 = grain1to3(iGrain,prm%Nconstituents) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain aVect = relaxationVector(intFace,instance,of) ! get the relaxation vectors for each interface from global relaxation vector array @@ -434,12 +434,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = getInterface(2_pInt*faceID(1),iGr3N) normN = interfaceNormal(intFaceN,instance,of) @@ -447,7 +447,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) normP = interfaceNormal(intFaceP,instance,of) @@ -577,12 +577,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,instance) ! assembling of local dPdF into global Jacobian matrix + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem - iGrN = grain3to1(iGr3N,instance) ! translate into global grain ID + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate into global grain ID intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = interfaceNormal(intFaceN,instance,of) do iFace = 1_pInt,6_pInt @@ -603,7 +603,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem - iGrP = grain3to1(iGr3P,instance) ! translate into global grain ID + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate into global grain ID intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system normP = interfaceNormal(intFaceP,instance,of) do iFace = 1_pInt,6_pInt @@ -649,12 +649,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! computing the global stress residual array from the perturbed state p_resid = 0.0_pReal do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,instance) ! identifying the interface ID in local coordinate system (4-dimensional index) + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = grain3to1(iGr3N,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain normN = interfaceNormal(intFaceN,instance,of) @@ -662,7 +662,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = grain3to1(iGr3P,instance) ! translate the local grain ID into global coordinate system (1-dimensional index) + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain normP = interfaceNormal(intFaceP,instance,of) @@ -845,7 +845,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector - iGrain3 = grain1to3(iGrain,instance) ! get the grain ID in local 3-dimensional index (x,y,z)-position + iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position !* Looping over all six interfaces of each grain do iFace = 1_pInt,6_pInt @@ -856,7 +856,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) where(iGNghb3 < 1) iGNghb3 = nGDim where(iGNghb3 >nGDim) iGNghb3 = 1_pInt - iGNghb = grain3to1(iGNghb3,instance) ! get the ID of the neighboring grain + iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) bgGNghb = Gmoduli(2) @@ -1013,12 +1013,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) constitutive_homogenizedC implicit none + real(pReal), dimension(2) :: equivalentModuli integer(pInt), intent(in) :: & grainID,& ip, & !< integration point number el !< element number - real(pReal), dimension (6,6) :: elasTens - real(pReal), dimension(2) :: equivalentModuli + real(pReal), dimension(6,6) :: elasTens real(pReal) :: & cEquiv_11, & cEquiv_12, & @@ -1064,7 +1064,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! compute the deformation gradient of individual grains due to relaxations F = 0.0_pReal do iGrain = 1_pInt,product(param(instance)%Nconstituents) - iGrain3 = grain1to3(iGrain,instance) + iGrain3 = grain1to3(iGrain,param(instance)%Nconstituents) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) aVect = relaxationVector(intFace,instance,of) @@ -1222,19 +1222,17 @@ pure function getInterface(iFace,iGrain3) end function getInterface + !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 1D (global array) to in 3D (local position) !-------------------------------------------------------------------------------------------------- -pure function grain1to3(grain1,instance) +pure function grain1to3(grain1,nGDim) implicit none - integer(pInt), dimension (3) :: grain1to3 - integer(pInt), intent(in) :: & - grain1,& !< grain ID in 1D array - instance - integer(pInt), dimension (3) :: nGDim + integer(pInt), dimension(3) :: grain1to3 + integer(pInt), intent(in) :: grain1 !< grain ID in 1D array + integer(pInt), dimension(3), intent(in) :: nGDim - nGDim = param(instance)%Nconstituents grain1to3 = 1_pInt + [mod((grain1-1_pInt),nGDim(1)), & mod((grain1-1_pInt)/nGDim(1),nGDim(2)), & (grain1-1_pInt)/(nGDim(1)*nGDim(2))] @@ -1245,16 +1243,16 @@ end function grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -pure function grain3to1(grain3,instance) +pure function grain3to1(grain3,nGDim) implicit none - integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) - integer(pInt), intent(in) :: instance ! homogenization ID - integer(pInt) :: grain3to1 - integer(pInt), dimension (3) :: nGDim + integer(pInt) :: grain3to1 + integer(pInt), dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) + integer(pInt), dimension(3), intent(in) :: nGDim - nGDim = param(instance)%Nconstituents - grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) + grain3to1 = grain3(1) & + + nGDim(1)*(grain3(2)-1_pInt) & + + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) end function grain3to1 @@ -1295,15 +1293,13 @@ end function interface4to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 1D (global array) into 4D (normal and local position) !-------------------------------------------------------------------------------------------------- -pure function interface1to4(iFace1D, instance) +pure function interface1to4(iFace1D, nGDim) implicit none - integer(pInt), dimension (4) :: interface1to4 + integer(pInt), dimension(4) :: interface1to4 integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array - integer(pInt), intent(in) :: instance - integer(pInt), dimension (3) :: nGDim,nIntFace - - nGDim = param(instance)%Nconstituents + integer(pInt), dimension(3), intent(in) :: nGDim + integer(pInt), dimension (3) :: nIntFace !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... From 7a37ea25f3f1111c20883bd3488f42d7b5cc2422 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 08:49:40 +0100 Subject: [PATCH 039/372] cleaning --- src/homogenization_RGC.f90 | 54 ++++++++++++++------------------ src/homogenization_isostrain.f90 | 11 +++---- src/homogenization_none.f90 | 7 ++--- 3 files changed, 30 insertions(+), 42 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index f1652f79b..04a0aff72 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -104,17 +104,12 @@ subroutine homogenization_RGC_init() debug_levelBasic, & debug_levelExtensive use math, only: & - math_Mandel3333to66,& - math_Voigt66to3333, & - math_I3, & - math_sampleRandomOri,& math_EulerToR,& INRAD use mesh, only: & mesh_NcpElems,& mesh_NipsPerElem, & - mesh_homogenizationAt, & - mesh_microstructureAt + mesh_homogenizationAt use IO use material use config @@ -383,8 +378,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) of = mappingHomogenization(1,ip,el) nGDim = param(instance)%Nconstituents nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) - nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & - + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) + nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & + + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & + + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) !-------------------------------------------------------------------------------------------------- ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster @@ -612,7 +608,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt - smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) + smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) enddo;enddo;enddo;enddo endif enddo @@ -637,6 +634,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) allocate(p_relax(3*nIntFaceTot), source=0.0_pReal) allocate(p_resid(3*nIntFaceTot), source=0.0_pReal) + do ipert = 1_pInt,3_pInt*nIntFaceTot p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector @@ -750,11 +748,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration drelax = 0.0_pReal - do i = 1_pInt,3_pInt*nIntFaceTot - do j = 1_pInt,3_pInt*nIntFaceTot - drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable - enddo - enddo + do i = 1_pInt,3_pInt*nIntFaceTot;do j = 1_pInt,3_pInt*nIntFaceTot + drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable + enddo; enddo relax = relax + drelax ! Updateing the state variable for the next iteration homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = relax if (any(abs(drelax) > maxdRelax_RGC)) then ! Forcing cutback when the incremental change of relaxation vector becomes too large @@ -790,8 +786,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) debug_levelExtensive, & debug_e, & debug_i - use mesh, only: & - mesh_homogenizationAt use constitutive, only: & constitutive_homogenizedC use math, only: & @@ -841,7 +835,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - do iGrain = 1_pInt,product(param(instance)%Nconstituents) + do iGrain = 1_pInt,product(prm%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector @@ -875,23 +869,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) - if (debugActive) then - write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb - write(6,*) transpose(nDef) - write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm - endif + if (debugActive) then + write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb + write(6,*) transpose(nDef) + write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm + endif !-------------------------------------------------------------------------------------------------- ! compute the stress penalty of all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & - *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & - *cosh(prm%ciAlpha*nDefNorm) & - *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & - *tanh(nDefNorm/xSmoo_RGC) - enddo; enddo - enddo; enddo + do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt; do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & + *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & + *cosh(prm%ciAlpha*nDefNorm) & + *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & + *tanh(nDefNorm/xSmoo_RGC) + enddo; enddo;enddo; enddo enddo if (debugActive) then diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 9c7f6752d..66acdd5e5 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -40,16 +40,13 @@ subroutine homogenization_isostrain_init() compiler_version, & compiler_options #endif - use prec, only: & - pReal use debug, only: & debug_HOMOGENIZATION, & debug_level, & debug_levelBasic use IO, only: & IO_timeStamp, & - IO_error, & - IO_warning + IO_error use material, only: & homogenization_type, & material_homog, & @@ -103,9 +100,9 @@ subroutine homogenization_isostrain_init() homogState(h)%sizeState = 0_pInt homogState(h)%sizePostResults = 0_pInt - allocate(homogState(h)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%state (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state0 (0_pInt,NofMyHomog)) + allocate(homogState(h)%subState0(0_pInt,NofMyHomog)) + allocate(homogState(h)%state (0_pInt,NofMyHomog)) end associate enddo diff --git a/src/homogenization_none.f90 b/src/homogenization_none.f90 index 0e23867f2..ebff9cdc9 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_none.f90 @@ -24,7 +24,6 @@ subroutine homogenization_none_init() compiler_options #endif use prec, only: & - pReal, & pInt use IO, only: & IO_timeStamp @@ -50,9 +49,9 @@ subroutine homogenization_none_init() NofMyHomog = count(material_homog == h) homogState(h)%sizeState = 0_pInt homogState(h)%sizePostResults = 0_pInt - allocate(homogState(h)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%state (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state0 (0_pInt,NofMyHomog)) + allocate(homogState(h)%subState0(0_pInt,NofMyHomog)) + allocate(homogState(h)%state (0_pInt,NofMyHomog)) enddo From c863419a0b4dc5c71162211ea0c199411c317f54 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 09:00:35 +0100 Subject: [PATCH 040/372] cleaning --- src/homogenization_RGC.f90 | 29 ++++++++++++----------------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 04a0aff72..2bb71be13 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -108,8 +108,7 @@ subroutine homogenization_RGC_init() INRAD use mesh, only: & mesh_NcpElems,& - mesh_NipsPerElem, & - mesh_homogenizationAt + mesh_NipsPerElem use IO use material use config @@ -121,7 +120,7 @@ subroutine homogenization_RGC_init() outputSize, & instance, & sizeHState, nIntFaceTot - integer(pInt) :: maxNinstance, i,j,e, mySize, of + integer(pInt) :: maxNinstance, i,j,e, of character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & outputID !< ID of each post result output @@ -236,7 +235,7 @@ subroutine homogenization_RGC_init() !-------------------------------------------------------------------------------------------------- ! * assigning cluster orientations elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_typeInstance(mesh_homogenizationAt(e)) == instance .and. NofMyHomog > 0_pInt) then + if (homogenization_typeInstance(material_homogenizationAt(e)) == instance .and. NofMyHomog > 0_pInt) then do i = 1_pInt,mesh_NipsPerElem of = mappingHomogenization(1,i,e) dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) @@ -321,9 +320,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) debug_i use math, only: & math_invert - use mesh, only: & - mesh_homogenizationAt use material, only: & + material_homogenizationAt, & homogenization_maxNgrains, & homogenization_typeInstance, & homogState, & @@ -374,10 +372,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) + instance = homogenization_typeInstance(material_homogenizationAt(el)) of = mappingHomogenization(1,ip,el) nGDim = param(instance)%Nconstituents - nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) + nGrain = homogenization_Ngrains(material_homogenizationAt(el)) nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) @@ -509,7 +507,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - do iGrain = 1_pInt,homogenization_Ngrains(mesh_homogenizationAt(el)) ! time-integration loop for work and energy + do iGrain = 1_pInt,homogenization_Ngrains(material_homogenizationAt(el)) ! time-integration loop for work and energy do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt state(instance)%work(of) = state(instance)%work(of) & + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) @@ -907,12 +905,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) debug_levelExtensive, & debug_e, & debug_i - use mesh, only: & - mesh_homogenizationAt use math, only: & math_det33, & math_inv33 use material, only: & + material_homogenizationAt, & homogenization_maxNgrains,& homogenization_Ngrains use numerics, only: & @@ -934,7 +931,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip - nGrain = homogenization_Ngrains(mesh_homogenizationAt(el)) + nGrain = homogenization_Ngrains(material_homogenizationAt(el)) !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster @@ -1096,11 +1093,9 @@ end subroutine homogenization_RGC_averageStressAndItsTangent !> @brief return array of homogenization results for post file inclusion !-------------------------------------------------------------------------------------------------- pure function homogenization_RGC_postResults(ip,el) result(postResults) - use mesh, only: & - mesh_homogenizationAt use material, only: & + material_homogenizationAt, & homogenization_typeInstance,& - homogState, & mappingHomogenization implicit none @@ -1110,10 +1105,10 @@ pure function homogenization_RGC_postResults(ip,el) result(postResults) integer(pInt) instance,o,c,of type(tParameters) :: prm - real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_homogenizationAt(el)))) :: & + real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(material_homogenizationAt(el)))) :: & postResults - instance = homogenization_typeInstance(mesh_homogenizationAt(el)) + instance = homogenization_typeInstance(material_homogenizationAt(el)) associate(prm => param(instance)) of = mappingHomogenization(1,ip,el) From 811a02eb519d1d2e36a1dcf20b306c86df5331cf Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 09:19:24 +0100 Subject: [PATCH 041/372] better readable --- src/homogenization_RGC.f90 | 61 +++++++++++++++++++++++--------------- 1 file changed, 37 insertions(+), 24 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 2bb71be13..b0978d24f 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -1230,10 +1230,9 @@ end function grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -pure function grain3to1(grain3,nGDim) +integer(pInt) pure function grain3to1(grain3,nGDim) implicit none - integer(pInt) :: grain3to1 integer(pInt), dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) integer(pInt), dimension(3), intent(in) :: nGDim @@ -1253,26 +1252,40 @@ integer(pInt) pure function interface4to1(iFace4D, nGDim) integer(pInt), dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) integer(pInt), dimension(3), intent(in) :: nGDim - interface4to1 = -1_pInt -!-------------------------------------------------------------------------------------------------- -! get the corresponding interface ID in 1D global array - if (abs(iFace4D(1)) == 1_pInt) then ! interface with normal //e1 - interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & - + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) - if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) interface4to1 = 0_pInt - elseif (abs(iFace4D(1)) == 2_pInt) then ! interface with normal //e2 - interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & - + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 - if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) interface4to1 = 0_pInt - elseif (abs(iFace4D(1)) == 3_pInt) then ! interface with normal //e3 - interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & - + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 - + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! total number of interfaces normal //e2 - if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) interface4to1 = 0_pInt - endif + select case(abs(iFace4D(1))) + + case(1_pInt) + if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) then + interface4to1 = 0_pInt + else + interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & + + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) + endif + + case(2_pInt) + if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) then + interface4to1 = 0_pInt + else + interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & + + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) & + + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 + endif + + case(3_pInt) + if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) then + interface4to1 = 0_pInt + else + interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & + + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) & + + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 + + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! total number of interfaces normal //e2 + endif + + case default + interface4to1 = -1_pInt + + end select end function interface4to1 @@ -1290,9 +1303,9 @@ pure function interface1to4(iFace1D, nGDim) !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... - nIntFace(1) = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! ... normal //e1 - nIntFace(2) = nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! ... normal //e2 - nIntFace(3) = nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) ! ... normal //e3 + nIntFace = [(nGDim(1)-1_pInt)*nGDim(2)*nGDim(3), & ! ... normal //e1 + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3), & ! ... normal //e2 + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt)] ! ... normal //e3 !-------------------------------------------------------------------------------------------------- ! get the corresponding interface ID in 4D (normal and local position) From 7386c6ff9c58302a97fc844b7a70d3d3e8667f49 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Nov 2018 20:16:12 +0100 Subject: [PATCH 042/372] no need for "use" statements will be inherited from outer function --- src/homogenization_RGC.f90 | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index b0978d24f..f26c38453 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -778,18 +778,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !> @brief calculate stress-like penalty due to deformation mismatch !-------------------------------------------------------------------------------------------------- subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) - use debug, only: & - debug_level, & - debug_homogenization,& - debug_levelExtensive, & - debug_e, & - debug_i - use constitutive, only: & - constitutive_homogenizedC use math, only: & math_civita - use material, only: & - homogenization_maxNgrains use numerics, only: & xSmoo_RGC @@ -899,19 +889,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !> @brief calculate stress-like penalty due to volume discrepancy !-------------------------------------------------------------------------------------------------- subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) - use debug, only: & - debug_level, & - debug_homogenization,& - debug_levelExtensive, & - debug_e, & - debug_i use math, only: & math_det33, & math_inv33 - use material, only: & - material_homogenizationAt, & - homogenization_maxNgrains,& - homogenization_Ngrains use numerics, only: & maxVolDiscr_RGC,& volDiscrMod_RGC,& @@ -1035,8 +1015,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! homogenization_RGC_partionDeformation, but used only for perturbation scheme) !-------------------------------------------------------------------------------------------------- subroutine grainDeformation(F, avgF, instance, of) - use material, only: & - homogenization_maxNgrains implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain From 58f2a25ffd2c17762d1b4493f0e0a80651673d72 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 15 Nov 2018 06:49:31 +0100 Subject: [PATCH 043/372] clearer separation of tasks 1) general HDF5_utilities (for results, restart, ...) 2) results related helpers (based on HDF5_utilities) --- src/results.f90 | 2341 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2341 insertions(+) create mode 100644 src/results.f90 diff --git a/src/results.f90 b/src/results.f90 new file mode 100644 index 000000000..43a7a26e8 --- /dev/null +++ b/src/results.f90 @@ -0,0 +1,2341 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Vitesh Shah, Max-Planck-Institut für Eisenforschung GmbH +!> @author Yi-Chin Yang, Max-Planck-Institut für Eisenforschung GmbH +!> @author Jennifer Nastola, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!-------------------------------------------------------------------------------------------------- +module HDF5_Utilities + use prec + use IO + use HDF5 +#ifdef PETSc + use PETSC +#endif + + implicit none + private + integer(HID_T), public, protected :: tempCoordinates, tempResults + integer(HID_T), private :: resultsFile, currentIncID, plist_id + integer(pInt), private :: currentInc + +!-------------------------------------------------------------------------------------------------- +!> @brief reads pInt or pReal data of defined shape from file +!-------------------------------------------------------------------------------------------------- + interface HDF5_read + module procedure HDF5_read_pReal_1 + module procedure HDF5_read_pReal_2 + module procedure HDF5_read_pReal_3 + module procedure HDF5_read_pReal_4 + module procedure HDF5_read_pReal_5 + module procedure HDF5_read_pReal_6 + module procedure HDF5_read_pReal_7 + + module procedure HDF5_read_pInt_1 + module procedure HDF5_read_pInt_2 + module procedure HDF5_read_pInt_3 + module procedure HDF5_read_pInt_4 + module procedure HDF5_read_pInt_5 + module procedure HDF5_read_pInt_6 + module procedure HDF5_read_pInt_7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK + + end interface HDF5_read + +!-------------------------------------------------------------------------------------------------- +!> @brief writes pInt or pReal data of defined shape to file +!-------------------------------------------------------------------------------------------------- + interface HDF5_write + module procedure HDF5_write_pReal1 + module procedure HDF5_write_pReal2 + module procedure HDF5_write_pReal3 + module procedure HDF5_write_pReal4 + module procedure HDF5_write_pReal5 + module procedure HDF5_write_pReal6 + module procedure HDF5_write_pReal7 + + module procedure HDF5_write_pInt1 + module procedure HDF5_write_pInt2 + module procedure HDF5_write_pInt3 + module procedure HDF5_write_pInt4 + module procedure HDF5_write_pInt5 + module procedure HDF5_write_pInt6 + module procedure HDF5_write_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK + + end interface HDF5_write + + public :: & + HDF5_Utilities_init, & + HDF5_mappingPhase, & + HDF5_mappingHomog, & + HDF5_mappingCrystallite, & + HDF5_backwardMappingPhase, & + HDF5_backwardMappingHomog, & + HDF5_backwardMappingCrystallite, & + HDF5_mappingCells, & + HDF5_addGroup ,& + HDF5_closeGroup ,& + HDF5_openGroup, & + HDF5_openGroup2, & + HDF5_forwardResults, & + HDF5_writeVectorDataset, & + HDF5_writeScalarDataset, & + HDF5_writeTensorDataset, & + HDF5_closeJobFile, & + HDF5_removeLink, & + HDF5_createFile, & + HDF5_closeFile, & + HDF5_addGroup2, & + HDF5_openFile, & + HDF5_read, & + HDF5_write +contains + +subroutine HDF5_Utilities_init + use, intrinsic :: & + iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + + implicit none + integer :: hdferr + integer(SIZE_T) :: typeSize + + write(6,'(/,a)') ' <<<+- HDF5_Utilities init -+>>>' +#include "compilation_info.f90" + + !currentInc = -1_pInt ToDo + !call HDF5_createJobFile ToDo + +!-------------------------------------------------------------------------------------------------- +!initialize HDF5 library and check if integer and float type size match + call h5open_f(hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5open_f') + call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)') + if (int(pInt,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pInt does not match H5T_NATIVE_INTEGER') + call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)') + if (int(pReal,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pReal does not match H5T_NATIVE_DOUBLE') + +end subroutine HDF5_Utilities_init + +!-------------------------------------------------------------------------------------------------- +!> @brief creates and initializes HDF5 output files +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_createJobFile + use hdf5 + use DAMASK_interface, only: & + getSolverJobName + + implicit none + integer :: hdferr + character(len=1024) :: path +#ifdef PETSc +#include + + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') + call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- +! open file + path = trim(getSolverJobName())//'.'//'hdf5' + !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) + call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) + call HDF5_addStringAttribute(resultsFile,'createdBy',DAMASKVERSION) + call h5pclose_f(plist_id, hdferr) !neu + +end subroutine HDF5_createJobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief creates and initializes HDF5 output files +!-------------------------------------------------------------------------------------------------- + integer(HID_T) function HDF5_createFile(path) + use hdf5 + use DAMASK_interface, only: & + getSolverJobName + + implicit none + integer :: hdferr + integer(SIZE_T) :: typeSize + character(len=*), intent(in) :: path +#ifdef PETSc +#include +#endif + call h5open_f(hdferr) !############################################################ DANGEROUS +#ifdef PETSc + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') + call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') +#endif +!-------------------------------------------------------------------------------------------------- +! create a file + !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) + call h5fcreate_f(path,H5F_ACC_TRUNC_F,HDF5_createFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) + !call HDF5_addStringAttribute(HDF5_createFile,'createdBy',DAMASKVERSION) + call h5pclose_f(plist_id, hdferr) !neu + +end function HDF5_createFile + +!-------------------------------------------------------------------------------------------------- +!> @brief close the opened HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_closeJobFile() + use hdf5 + + implicit none + integer :: hdferr + call HDF5_removeLink('current') + call h5fclose_f(resultsFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f',el=hdferr) +! call h5close_f(hdferr) + +end subroutine HDF5_closeJobFile + +!-------------------------------------------------------------------------------------------------- +!> @brief open and initializes HDF5 output file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_openFile(fileName,mode) + + implicit none + character(len=*), intent(in) :: fileName + character, intent(in), optional :: mode + character :: m + integer :: hdferr + + if (present(mode)) then + m = mode + else + m = 'r' + endif + + if (m == 'w') then + call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) + elseif(m == 'a') then + call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)',el=hdferr) + elseif(m == 'r') then + call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)',el=hdferr) + else + call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode',el=hdferr) + endif + +end function HDF5_openFile + +!-------------------------------------------------------------------------------------------------- +!> @brief close the opened HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_closeFile(fileHandle) + + implicit none + integer :: hdferr + integer(HID_T), intent(in) :: fileHandle + call h5fclose_f(fileHandle,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f',el=hdferr) + +end subroutine HDF5_closeFile + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the results file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_addGroup(groupName) + use hdf5 + + implicit none + character(len=*), intent(in) :: groupName + integer :: hdferr + + call h5gcreate_f(resultsFile, trim(groupName), HDF5_addGroup, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') + +end function HDF5_addGroup + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the fileHandle (additional to addGroup2) +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_addGroup2(fileHandle,groupName) + use hdf5 + + implicit none + character(len=*), intent(in) :: groupName + integer(HID_T), intent(in) :: fileHandle + integer :: hdferr + + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') + +end function HDF5_addGroup2 + + +!-------------------------------------------------------------------------------------------------- +!> @brief open a group from the results file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_openGroup(groupName) + use hdf5 + + implicit none + character(len=*), intent(in) :: groupName + integer :: hdferr + + call h5gopen_f(resultsFile, trim(groupName), HDF5_openGroup, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + +end function HDF5_openGroup + +!-------------------------------------------------------------------------------------------------- +!> @brief open an existing group of a file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) + use hdf5 + + implicit none + character(len=*), intent(in) :: groupName + integer :: hdferr + integer(HID_T), intent(in) :: FileReadID + + call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5gopen_f ('//trim(groupName)//')') + +end function HDF5_openGroup2 + +!-------------------------------------------------------------------------------------------------- +!> @brief set link to object in results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_setLink(path,link) + use hdf5 + + implicit none + character(len=*), intent(in) :: path, link + integer :: hdferr + logical :: linkExists + + call h5lexists_f(resultsFile, link,linkExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link)//')') + if (linkExists) then + call h5ldelete_f(resultsFile,link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link)//')') + endif + call h5lcreate_soft_f(path, resultsFile, link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(path)//' '//trim(link)//')') + +end subroutine HDF5_setLink + +!-------------------------------------------------------------------------------------------------- +!> @brief remove link to an object +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_removeLink(link) + use hdf5 + + implicit none + character(len=*), intent(in) :: link + integer :: hdferr + + call h5ldelete_f(resultsFile,link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_removeLink: h5ldelete_soft_f ('//trim(link)//')') + +end subroutine HDF5_removeLink + +!-------------------------------------------------------------------------------------------------- +!> @brief close a group +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_closeGroup(ID) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: ID + integer :: hdferr + + call h5gclose_f(ID, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(ID,pInt)) + +end subroutine HDF5_closeGroup + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a StringAttribute to the results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: entity + character(len=*), intent(in) :: attrLabel, attrValue + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5screate_f') + call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tcopy_f') + call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tset_size_f') + call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5acreate_f') + call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5sclose_f') + +end subroutine HDF5_addStringAttribute + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) + use hdf5 + + implicit none + integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset + integer(pInt), intent(in), dimension(:) :: mapping, mapping2 + character(len=*), intent(in), dimension(:) :: phase_name + integer(pInt), intent(in), dimension(:) :: mpiOffset_phase + integer(pInt), intent(in), dimension(:,:,:) :: material_phase + + character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA + character(len=len(phase_name(1))) :: a + character(len=*), parameter :: n = "NULL" + + integer(pInt) :: hdferr, NmatPoints, i, j, k + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace + integer(HID_T) :: dt5_id ! Memory datatype identifier + integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + + integer(HSIZE_T), dimension(2) :: counter + integer(HSSIZE_T), dimension(2) :: fileOffset + integer(pInt), dimension(:,:), allocatable :: arrOffset + + a = n + allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) + NmatPoints = size(mapping,1)/Nconstituents + mapping_ID = HDF5_openGroup("current/mapGeometry") + + allocate(arrOffset(Nconstituents,NmatPoints)) + do i=1_pInt, NmatPoints + do k=1_pInt, Nconstituents + do j=1_pInt, size(phase_name) + if(material_phase(k,1,i) == j) & + arrOffset(k,i) = mpiOffset_phase(j) + enddo + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & + int([Nconstituents,dataspace_size],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!-------------------------------------------------------------------------------------------------- +! compound type + ! First calculate total size by calculating sizes of each member + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) + typesize = len(phase_name(1)) + CALL h5tset_size_f(dt5_id, typesize, hdferr) + CALL h5tget_size_f(dt5_id, type_sizec, hdferr) + CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) + type_size = type_sizec + type_sizei + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') + call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') + +!-------------------------------------------------------------------------------------------------- +! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') + + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- +! Define and select hyperslabs + counter(1) = Nconstituents ! how big i am + counter(2) = NmatPoints + fileOffset(1) = 0 ! where i start to write my data + fileOffset(2) = mpiOffset + + call h5screate_simple_f(2, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & + int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & + file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & + int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & + file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- +! close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') + call h5tclose_f(name_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') + call h5tclose_f(dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') + call h5sclose_f(memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') + call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingPhase + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the backward mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat + character(len=*), intent(in), dimension(:) :: phase_name + integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase + integer(pInt), intent(in) :: mpiOffset + + integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace + integer(SIZE_T) :: type_size + + integer(pInt), dimension(:,:), allocatable :: arr + + integer(HSIZE_T), dimension(1) :: counter + integer(HSSIZE_T), dimension(1) :: fileOffset + + character(len=64) :: phaseID + + Nconstituents = size(phasememberat,1) + NmatPoints = count(material_phase /=0_pInt)/Nconstituents + + allocate(arr(2,NmatPoints*Nconstituents)) + + do i=1_pInt, NmatPoints + do j=Nconstituents-1_pInt, 0_pInt, -1_pInt + arr(1,Nconstituents*i-j) = i-1_pInt + enddo + enddo + arr(2,:) = pack(material_phase,material_phase/=0_pInt) + + do i=1_pInt, size(phase_name) + write(phaseID, '(i0)') i + mapping_ID = HDF5_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) + NmatPoints = count(material_phase == i) + +!-------------------------------------------------------------------------------------------------- + ! create dataspace + call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & + int([dataspace_size(i)],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!-------------------------------------------------------------------------------------------------- + ! compound type + call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') + +!-------------------------------------------------------------------------------------------------- + ! create Dataset + call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') + +!-------------------------------------------------------------------------------------------------- + ! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- + ! Define and select hyperslabs + counter = NmatPoints ! how big i am + fileOffset = mpiOffset_phase(i) ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- + ! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& + hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- + !close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') + call h5sclose_f(memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') + call HDF5_closeGroup(mapping_ID) + + enddo + +end subroutine HDF5_backwardMappingPhase + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat + character(len=*), intent(in), dimension(:) :: homogenization_name + integer(pInt), intent(in), dimension(:) :: mpiOffset_homog + integer(pInt), intent(in) :: dataspace_size, mpiOffset + + integer(pInt) :: hdferr, NmatPoints, i, j + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace + + integer(HID_T) :: dt5_id ! Memory datatype identifier + integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + + integer(HSIZE_T), dimension(1) :: counter + integer(HSSIZE_T), dimension(1) :: fileOffset + integer(pInt), dimension(:), allocatable :: arrOffset + + NmatPoints = count(material_homog /=0_pInt) + mapping_ID = HDF5_openGroup("current/mapGeometry") + + allocate(arrOffset(NmatPoints)) + do i=1_pInt, NmatPoints + do j=1_pInt, size(homogenization_name) + if(material_homog(1,i) == j) & + arrOffset(i) = mpiOffset_homog(j) + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & + int([dataspace_size],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!-------------------------------------------------------------------------------------------------- +! compound type + ! First calculate total size by calculating sizes of each member + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) + typesize = len(homogenization_name(1)) + CALL h5tset_size_f(dt5_id, typesize, hdferr) + CALL h5tget_size_f(dt5_id, type_sizec, hdferr) + CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) + type_size = type_sizec + type_sizei + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') + call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') + +!-------------------------------------------------------------------------------------------------- +! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') + + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- +! Define and select hyperslabs + counter = NmatPoints ! how big i am + fileOffset = mpiOffset ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & + int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & + mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & + int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & + mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces +call h5tclose_f(dtype_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') +call h5tclose_f(position_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') +call h5tclose_f(name_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') +call h5tclose_f(dt5_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') +call h5dclose_f(dset_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') +call h5sclose_f(space_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') +call h5sclose_f(memspace, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') +call h5pclose_f(plist_id, hdferr) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') +call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingHomog + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the backward mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat + character(len=*), intent(in), dimension(:) :: homogenization_name + integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog + integer(pInt), intent(in) :: mpiOffset + + integer(pInt) :: hdferr, NmatPoints, i + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace + integer(SIZE_T) :: type_size + + integer(pInt), dimension(:,:), allocatable :: arr + + integer(HSIZE_T), dimension(1) :: counter + integer(HSSIZE_T), dimension(1) :: fileOffset + + character(len=64) :: homogID + + NmatPoints = count(material_homog /=0_pInt) + allocate(arr(2,NmatPoints)) + + arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) + arr(2,:) = pack(material_homog,material_homog/=0_pInt) + + do i=1_pInt, size(homogenization_name) + write(homogID, '(i0)') i + mapping_ID = HDF5_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) + +!-------------------------------------------------------------------------------------------------- + ! create dataspace + call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & + int([dataspace_size(i)],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!-------------------------------------------------------------------------------------------------- + ! compound type + call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') + +!-------------------------------------------------------------------------------------------------- + ! create Dataset + call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') + +!-------------------------------------------------------------------------------------------------- + ! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- + ! Define and select hyperslabs + counter = NmatPoints ! how big i am + fileOffset = mpiOffset_homog(i) ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- + ! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& + hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- + !close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') + call h5sclose_f(memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') + call HDF5_closeGroup(mapping_ID) + + enddo + +end subroutine HDF5_backwardMappingHomog + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:) :: crystalliteAt + integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt + character(len=*), intent(in), dimension(:) :: crystallite_name + integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst + integer(pInt), intent(in) :: dataspace_size, mpiOffset + + integer :: hdferr + integer(pInt) :: NmatPoints, Nconstituents, i, j + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace + + integer(HID_T), dimension(:), allocatable :: position_id + + integer(HID_T) :: dt5_id ! Memory datatype identifier + integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + + integer(HSIZE_T), dimension(1) :: counter + integer(HSSIZE_T), dimension(1) :: fileOffset + integer(pInt), dimension(:), allocatable :: arrOffset + + character(len=64) :: m + + Nconstituents = size(crystmemberAt,1) + NmatPoints = count(crystalliteAt /=0_pInt) + mapping_ID = HDF5_openGroup("current/mapGeometry") + + allocate(position_id(Nconstituents)) + + allocate(arrOffset(NmatPoints)) + do i=1_pInt, NmatPoints + do j=1_pInt, size(crystallite_name) + if(crystalliteAt(1,i) == j) & + arrOffset(i) = Nconstituents*mpiOffset_cryst(j) + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & + int([dataspace_size],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!-------------------------------------------------------------------------------------------------- +! compound type + ! First calculate total size by calculating sizes of each member + ! + CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) + typesize = len(crystallite_name(1)) + CALL h5tset_size_f(dt5_id, typesize, hdferr) + CALL h5tget_size_f(dt5_id, type_sizec, hdferr) + CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) + type_size = type_sizec + type_sizei*Nconstituents + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') + do i=1_pInt, Nconstituents + write(m, '(i0)') i + call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) + enddo + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') + +!-------------------------------------------------------------------------------------------------- +! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') + + do i=1_pInt, Nconstituents + write(m, '(i0)') i + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') + call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') + enddo + +!-------------------------------------------------------------------------------------------------- +! Define and select hyperslabs + counter = NmatPoints ! how big i am + fileOffset = mpiOffset ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & + int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & + mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') + + do i=1_pInt, Nconstituents + call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& + int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & + mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') + enddo + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') + do i=1_pInt, Nconstituents + call h5tclose_f(position_id(i), hdferr) + enddo + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') + call h5tclose_f(name_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') + call h5tclose_f(dt5_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') + call h5sclose_f(memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') + call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingCrystallite + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the backward mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:) :: crystalliteAt + integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt + character(len=*), intent(in), dimension(:) :: crystallite_name + integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst + integer(pInt), intent(in) :: mpiOffset + + integer :: hdferr + integer(pInt) :: NmatPoints, Nconstituents, i, j + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace + integer(SIZE_T) :: type_size + + integer(pInt), dimension(:,:), allocatable :: h_arr, arr + + integer(HSIZE_T), dimension(1) :: counter + integer(HSSIZE_T), dimension(1) :: fileOffset + + character(len=64) :: crystallID + + Nconstituents = size(crystmemberAt,1) + NmatPoints = count(crystalliteAt /=0_pInt) + + allocate(h_arr(2,NmatPoints)) + allocate(arr(2,Nconstituents*NmatPoints)) + + h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) + h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) + + do i=1_pInt, NmatPoints + do j=Nconstituents-1_pInt, 0_pInt, -1_pInt + arr(1,Nconstituents*i-j) = h_arr(1,i) + arr(2,Nconstituents*i-j) = h_arr(2,i) + enddo + enddo + + do i=1_pInt, size(crystallite_name) + if (crystallite_name(i) == 'none') cycle + write(crystallID, '(i0)') i + mapping_ID = HDF5_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) + NmatPoints = count(crystalliteAt == i) + +!-------------------------------------------------------------------------------------------------- + ! create dataspace + call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & + int([Nconstituents*dataspace_size(i)],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!-------------------------------------------------------------------------------------------------- + ! compound type + call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') + +!-------------------------------------------------------------------------------------------------- + ! create Dataset + call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') + +!-------------------------------------------------------------------------------------------------- + ! Create memory types + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- + ! Define and select hyperslabs + counter = Nconstituents*NmatPoints ! how big i am + fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') +#endif + +!-------------------------------------------------------------------------------------------------- + ! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& + int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & + mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- + !close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') + call h5sclose_f(memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') + call HDF5_closeGroup(mapping_ID) + + enddo + +end subroutine HDF5_backwardMappingCrystallite + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique cell to node mapping +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingCells(mapping) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:) :: mapping + + integer :: hdferr, Nnodes + integer(HID_T) :: mapping_id, dset_id, space_id + + Nnodes=size(mapping) + mapping_ID = HDF5_openGroup("mapping") + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & + int([Nnodes],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') + call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingCells + +!-------------------------------------------------------------------------------------------------- +!> @brief creates a new 3D Tensor dataset in the given group location !!!TODO: really necessary? +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addTensor3DDataset(group,Nnodes,tensorSize,label,SIunit) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + integer(pInt), intent(in) :: Nnodes, tensorSize + character(len=*), intent(in) :: SIunit, label + + integer :: hdferr + integer(HID_T) :: space_id, dset_id + integer(HSIZE_T), dimension(3) :: dataShape + + dataShape = int([tensorSize,tensorSize,Nnodes], HSIZE_T) + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(3, dataShape, space_id, hdferr, dataShape) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5screate_simple_f') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dcreate_f') + call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dclose_f') + call h5sclose_f(space_id, hdferr) + +end subroutine HDF5_addTensor3DDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief creates a new vector dataset in the given group location !!!TODO: really necessary? +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_writeVectorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + character(len=*), intent(in) :: SIunit,label + integer(pInt), intent(in) :: dataspace_size, mpiOffset + real(pReal), intent(in), dimension(:,:) :: dataset + + integer :: hdferr, vectorSize + integer(HID_T) :: dset_id, space_id, memspace, plist_id + + integer(HSIZE_T), dimension(2) :: counter + integer(HSSIZE_T), dimension(2) :: fileOffset + + if(any(shape(dataset) == 0)) return + + vectorSize = size(dataset,1) + + call HDF5_addVectorDataset(group,dataspace_size,vectorSize,label,SIunit) ! here nNodes need to be global + call h5dopen_f(group, label, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dopen_f') + + ! Define and select hyperslabs + counter(1) = vectorSize ! how big i am + counter(2) = size(dataset,2) + fileOffset(1) = 0 ! where i start to write my data + fileOffset(2) = mpiOffset + + call h5screate_simple_f(2, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5sselect_hyperslab_f') + + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pset_dxpl_mpio_f') +#endif + + ! Write the dataset collectively + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([vectorSize, dataspace_size],HSIZE_T), hdferr, & + file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dwrite_f') + + call h5sclose_f(space_id, hdferr) + call h5sclose_f(memspace, hdferr) + call h5dclose_f(dset_id, hdferr) + call h5pclose_f(plist_id, hdferr) + +end subroutine HDF5_writeVectorDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief creates a new tensor dataset in the given group location +! by default, a 3x3 tensor is assumed !!!TODO: really necessary? +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_writeTensorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + character(len=*), intent(in) :: SIunit,label + integer(pInt), intent(in) :: dataspace_size, mpiOffset + real(pReal), intent(in), dimension(:,:,:) :: dataset + + integer :: hdferr, tensorSize + integer(HID_T) :: dset_id, space_id, memspace, plist_id + + integer(HSIZE_T), dimension(3) :: counter + integer(HSSIZE_T), dimension(3) :: fileOffset + + if(any(shape(dataset) == 0)) return + + tensorSize = size(dataset,1) + + call HDF5_addTensor3DDataset(group,dataspace_size,tensorSize,label,SIunit) + call h5dopen_f(group, label, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dopen_f') + + ! Define and select hyperslabs + counter(1) = tensorSize ! how big i am + counter(2) = tensorSize + counter(3) = size(dataset,3) + fileOffset(1) = 0 ! where i start to write my data + fileOffset(2) = 0 + fileOffset(3) = mpiOffset + + call h5screate_simple_f(3, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5sselect_hyperslab_f') + + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pset_dxpl_mpio_f') +#endif + + ! Write the dataset collectively + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([tensorSize, dataspace_size],HSIZE_T), hdferr, & + file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dwrite_f') + + call h5sclose_f(space_id, hdferr) + call h5sclose_f(memspace, hdferr) + call h5dclose_f(dset_id, hdferr) + call h5pclose_f(plist_id, hdferr) + + end subroutine HDF5_writeTensorDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new vector dataset to the given group location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addVectorDataset(group,nnodes,vectorSize,label,SIunit) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + integer(pInt), intent(in) :: nnodes,vectorSize + character(len=*), intent(in) :: SIunit,label + + integer :: hdferr + integer(HID_T) :: space_id, dset_id + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(2, int([vectorSize,Nnodes],HSIZE_T), space_id, hdferr, & + int([vectorSize,Nnodes],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5screate_simple_f') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(group, trim(label), H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dcreate_f') + call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dclose_f') + call h5sclose_f(space_id, hdferr) + +end subroutine HDF5_addVectorDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief writes to a new scalar dataset in the given group location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_writeScalarDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + character(len=*), intent(in) :: SIunit,label + integer(pInt), intent(in) :: dataspace_size, mpiOffset + real(pReal), intent(in), dimension(:) :: dataset + + integer :: hdferr, nNodes + integer(HID_T) :: dset_id, space_id, memspace, plist_id + + integer(HSIZE_T), dimension(1) :: counter + integer(HSIZE_T), dimension(1) :: fileOffset + + nNodes = size(dataset) + if (nNodes < 1) return + + call HDF5_addScalarDataset(group,dataspace_size,label,SIunit) + call h5dopen_f(group, label, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dopen_f') + + ! Define and select hyperslabs + counter = size(dataset) ! how big i am + fileOffset = mpiOffset ! where i start to write my data + + call h5screate_simple_f(1, counter, memspace, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5screate_simple_f') + call h5dget_space_f(dset_id, space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dget_space_f') + call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5sselect_hyperslab_f') + + ! Create property list for collective dataset write +#ifdef PETSc + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pcreate_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pset_dxpl_mpio_f') +#endif + + ! Write the dataset collectively + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([dataspace_size],HSIZE_T), hdferr, & + file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dwrite_f') + + call h5sclose_f(space_id, hdferr) + call h5sclose_f(memspace, hdferr) + call h5dclose_f(dset_id, hdferr) + call h5pclose_f(plist_id, hdferr) + +end subroutine HDF5_writeScalarDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 1 dimension +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_1(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dclose_f') + +end subroutine HDF5_read_pReal_1 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_2(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dclose_f') + +end subroutine HDF5_read_pReal_2 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_3(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dclose_f') + +end subroutine HDF5_read_pReal_3 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_4(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dclose_f') + +end subroutine HDF5_read_pReal_4 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') + +end subroutine HDF5_read_pReal_5 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 6 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_6(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dclose_f') + +end subroutine HDF5_read_pReal_6 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pReal with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal_7(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dclose_f') + +end subroutine HDF5_read_pReal_7 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 1 dimension +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_1(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dclose_f') + +end subroutine HDF5_read_pInt_1 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_2(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dclose_f') + +end subroutine HDF5_read_pInt_2 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_3(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dclose_f') + +end subroutine HDF5_read_pInt_3 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_4(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dclose_f') + +end subroutine HDF5_read_pInt_4 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_5(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dclose_f') + +end subroutine HDF5_read_pInt_5 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 6 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_6(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dclose_f') + +end subroutine HDF5_read_pInt_6 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of the type pInt with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + integer(pInt),dimension(:), allocatable :: myShape + + integer :: hdferr + integer(HID_T) :: dset_id + myShape = shape(dataset) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dopen_f') + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dread_f') + call h5dclose_f(dset_id,hdferr) + if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dclose_f') + +end subroutine HDF5_read_pInt_7 + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for writing dataset of the type pReal with 1 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal1(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal2(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal3(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal4(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal5(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 6 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal6(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pReal7(dataset,loc_id,datasetName) + + implicit none + real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 1 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt1(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt2(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt3(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt4(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt5(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 6 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt6(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_pInt7(dataset,loc_id,datasetName) + + implicit none + integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + + integer(pInt), dimension(:), allocatable :: myShape ! @brief adds a new scalar dataset to the given group location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addScalarDataset(group,nnodes,label,SIunit) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + integer(pInt), intent(in) :: nnodes + character(len=*), intent(in) :: SIunit,label + + integer :: hdferr + integer(HID_T) :: space_id, dset_id + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & + int([Nnodes],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5screate_simple_f') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dcreate_f') + call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dclose_f') + call h5sclose_f(space_id, hdferr) + +end subroutine HDF5_addScalarDataset + +!-------------------------------------------------------------------------------------------------- +!> @brief copies the current temp results to the actual results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_forwardResults(time) + use hdf5 + use IO, only: & + IO_intOut + + implicit none + integer :: hdferr + integer(HID_T) :: currentIncID + real(pReal), intent(in) :: time + character(len=1024) :: myName + + currentInc = currentInc +1_pInt + write(6,*) 'forward results';flush(6) + write(myName,'(a,'//IO_intOut(currentInc)//')') 'inc',currentInc + currentIncID = HDF5_addGroup(myName) + call HDF5_setLink(myName,'current') +! call HDF5_flush(resultsFile) + call HDF5_closeGroup(currentIncID) + +end subroutine HDF5_forwardResults + +end module HDF5_Utilities \ No newline at end of file From b48bd3a08223d794fe52368bfdbefe08dbbf4bcd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 15 Nov 2018 07:07:59 +0100 Subject: [PATCH 044/372] keep only general functionality in HDF5_results --- src/HDF5_utilities.f90 | 1267 +--------------------------------------- 1 file changed, 3 insertions(+), 1264 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 43a7a26e8..1193eb25d 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -63,25 +63,9 @@ module HDF5_Utilities end interface HDF5_write public :: & - HDF5_Utilities_init, & - HDF5_mappingPhase, & - HDF5_mappingHomog, & - HDF5_mappingCrystallite, & - HDF5_backwardMappingPhase, & - HDF5_backwardMappingHomog, & - HDF5_backwardMappingCrystallite, & - HDF5_mappingCells, & - HDF5_addGroup ,& + HDF5_utilities_init, & HDF5_closeGroup ,& - HDF5_openGroup, & HDF5_openGroup2, & - HDF5_forwardResults, & - HDF5_writeVectorDataset, & - HDF5_writeScalarDataset, & - HDF5_writeTensorDataset, & - HDF5_closeJobFile, & - HDF5_removeLink, & - HDF5_createFile, & HDF5_closeFile, & HDF5_addGroup2, & HDF5_openFile, & @@ -100,9 +84,6 @@ subroutine HDF5_Utilities_init write(6,'(/,a)') ' <<<+- HDF5_Utilities init -+>>>' #include "compilation_info.f90" - !currentInc = -1_pInt ToDo - !call HDF5_createJobFile ToDo - !-------------------------------------------------------------------------------------------------- !initialize HDF5 library and check if integer and float type size match call h5open_f(hdferr) @@ -116,36 +97,7 @@ subroutine HDF5_Utilities_init end subroutine HDF5_Utilities_init -!-------------------------------------------------------------------------------------------------- -!> @brief creates and initializes HDF5 output files -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_createJobFile - use hdf5 - use DAMASK_interface, only: & - getSolverJobName - implicit none - integer :: hdferr - character(len=1024) :: path -#ifdef PETSc -#include - - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! open file - path = trim(getSolverJobName())//'.'//'hdf5' - !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) - call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) - call HDF5_addStringAttribute(resultsFile,'createdBy',DAMASKVERSION) - call h5pclose_f(plist_id, hdferr) !neu - -end subroutine HDF5_createJobFile !-------------------------------------------------------------------------------------------------- @@ -180,20 +132,7 @@ end subroutine HDF5_createJobFile end function HDF5_createFile -!-------------------------------------------------------------------------------------------------- -!> @brief close the opened HDF5 output file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeJobFile() - use hdf5 - implicit none - integer :: hdferr - call HDF5_removeLink('current') - call h5fclose_f(resultsFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f',el=hdferr) -! call h5close_f(hdferr) - -end subroutine HDF5_closeJobFile !-------------------------------------------------------------------------------------------------- !> @brief open and initializes HDF5 output file @@ -227,6 +166,7 @@ integer(HID_T) function HDF5_openFile(fileName,mode) end function HDF5_openFile + !-------------------------------------------------------------------------------------------------- !> @brief close the opened HDF5 output file !-------------------------------------------------------------------------------------------------- @@ -240,21 +180,6 @@ subroutine HDF5_closeFile(fileHandle) end subroutine HDF5_closeFile -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new group to the results file -!-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup(groupName) - use hdf5 - - implicit none - character(len=*), intent(in) :: groupName - integer :: hdferr - - call h5gcreate_f(resultsFile, trim(groupName), HDF5_addGroup, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') - -end function HDF5_addGroup - !-------------------------------------------------------------------------------------------------- !> @brief adds a new group to the fileHandle (additional to addGroup2) @@ -273,21 +198,6 @@ integer(HID_T) function HDF5_addGroup2(fileHandle,groupName) end function HDF5_addGroup2 -!-------------------------------------------------------------------------------------------------- -!> @brief open a group from the results file -!-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openGroup(groupName) - use hdf5 - - implicit none - character(len=*), intent(in) :: groupName - integer :: hdferr - - call h5gopen_f(resultsFile, trim(groupName), HDF5_openGroup, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') - -end function HDF5_openGroup - !-------------------------------------------------------------------------------------------------- !> @brief open an existing group of a file !-------------------------------------------------------------------------------------------------- @@ -304,42 +214,6 @@ integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) end function HDF5_openGroup2 -!-------------------------------------------------------------------------------------------------- -!> @brief set link to object in results file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_setLink(path,link) - use hdf5 - - implicit none - character(len=*), intent(in) :: path, link - integer :: hdferr - logical :: linkExists - - call h5lexists_f(resultsFile, link,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link)//')') - if (linkExists) then - call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link)//')') - endif - call h5lcreate_soft_f(path, resultsFile, link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(path)//' '//trim(link)//')') - -end subroutine HDF5_setLink - -!-------------------------------------------------------------------------------------------------- -!> @brief remove link to an object -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_removeLink(link) - use hdf5 - - implicit none - character(len=*), intent(in) :: link - integer :: hdferr - - call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_removeLink: h5ldelete_soft_f ('//trim(link)//')') - -end subroutine HDF5_removeLink !-------------------------------------------------------------------------------------------------- !> @brief close a group @@ -356,1084 +230,6 @@ subroutine HDF5_closeGroup(ID) end subroutine HDF5_closeGroup -!-------------------------------------------------------------------------------------------------- -!> @brief adds a StringAttribute to the results file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: entity - character(len=*), intent(in) :: attrLabel, attrValue - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5screate_f') - call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tcopy_f') - call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tset_size_f') - call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5acreate_f') - call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5sclose_f') - -end subroutine HDF5_addStringAttribute - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 - - implicit none - integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset - integer(pInt), intent(in), dimension(:) :: mapping, mapping2 - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_phase - integer(pInt), intent(in), dimension(:,:,:) :: material_phase - - character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA - character(len=len(phase_name(1))) :: a - character(len=*), parameter :: n = "NULL" - - integer(pInt) :: hdferr, NmatPoints, i, j, k - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(2) :: counter - integer(HSSIZE_T), dimension(2) :: fileOffset - integer(pInt), dimension(:,:), allocatable :: arrOffset - - a = n - allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) - NmatPoints = size(mapping,1)/Nconstituents - mapping_ID = HDF5_openGroup("current/mapGeometry") - - allocate(arrOffset(Nconstituents,NmatPoints)) - do i=1_pInt, NmatPoints - do k=1_pInt, Nconstituents - do j=1_pInt, size(phase_name) - if(material_phase(k,1,i) == j) & - arrOffset(k,i) = mpiOffset_phase(j) - enddo - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & - int([Nconstituents,dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(phase_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter(1) = Nconstituents ! how big i am - counter(2) = NmatPoints - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = mpiOffset - - call h5screate_simple_f(2, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') - - call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -! close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingPhase - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase - integer(pInt), intent(in) :: mpiOffset - - integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: phaseID - - Nconstituents = size(phasememberat,1) - NmatPoints = count(material_phase /=0_pInt)/Nconstituents - - allocate(arr(2,NmatPoints*Nconstituents)) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = i-1_pInt - enddo - enddo - arr(2,:) = pack(material_phase,material_phase/=0_pInt) - - do i=1_pInt, size(phase_name) - write(phaseID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) - NmatPoints = count(material_phase == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_phase(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingPhase - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_homog - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - NmatPoints = count(material_homog /=0_pInt) - mapping_ID = HDF5_openGroup("current/mapGeometry") - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(homogenization_name) - if(material_homog(1,i) == j) & - arrOffset(i) = mpiOffset_homog(j) - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(homogenization_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') - - call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces -call h5tclose_f(dtype_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') -call h5tclose_f(position_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') -call h5tclose_f(name_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') -call h5tclose_f(dt5_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') -call h5dclose_f(dset_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') -call h5sclose_f(space_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') -call h5sclose_f(memspace, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') -call h5pclose_f(plist_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') -call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingHomog - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog - integer(pInt), intent(in) :: mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: homogID - - NmatPoints = count(material_homog /=0_pInt) - allocate(arr(2,NmatPoints)) - - arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) - arr(2,:) = pack(material_homog,material_homog/=0_pInt) - - do i=1_pInt, size(homogenization_name) - write(homogID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_homog(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingHomog - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace - - integer(HID_T), dimension(:), allocatable :: position_id - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - character(len=64) :: m - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - mapping_ID = HDF5_openGroup("current/mapGeometry") - - allocate(position_id(Nconstituents)) - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(crystallite_name) - if(crystalliteAt(1,i) == j) & - arrOffset(i) = Nconstituents*mpiOffset_cryst(j) - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(crystallite_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) - type_size = type_sizec + type_sizei*Nconstituents - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) - enddo - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') - - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') - enddo - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') - - do i=1_pInt, Nconstituents - call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') - enddo - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') - do i=1_pInt, Nconstituents - call h5tclose_f(position_id(i), hdferr) - enddo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCrystallite - - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst - integer(pInt), intent(in) :: mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: h_arr, arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: crystallID - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - - allocate(h_arr(2,NmatPoints)) - allocate(arr(2,Nconstituents*NmatPoints)) - - h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) - h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = h_arr(1,i) - arr(2,Nconstituents*i-j) = h_arr(2,i) - enddo - enddo - - do i=1_pInt, size(crystallite_name) - if (crystallite_name(i) == 'none') cycle - write(crystallID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) - NmatPoints = count(crystalliteAt == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([Nconstituents*dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = Nconstituents*NmatPoints ! how big i am - fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& - int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingCrystallite - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique cell to node mapping -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCells(mapping) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:) :: mapping - - integer :: hdferr, Nnodes - integer(HID_T) :: mapping_id, dset_id, space_id - - Nnodes=size(mapping) - mapping_ID = HDF5_openGroup("mapping") - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & - int([Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCells - -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new 3D Tensor dataset in the given group location !!!TODO: really necessary? -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addTensor3DDataset(group,Nnodes,tensorSize,label,SIunit) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: Nnodes, tensorSize - character(len=*), intent(in) :: SIunit, label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - integer(HSIZE_T), dimension(3) :: dataShape - - dataShape = int([tensorSize,tensorSize,Nnodes], HSIZE_T) - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(3, dataShape, space_id, hdferr, dataShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addTensor3DDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new vector dataset in the given group location !!!TODO: really necessary? -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeVectorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset - real(pReal), intent(in), dimension(:,:) :: dataset - - integer :: hdferr, vectorSize - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(2) :: counter - integer(HSSIZE_T), dimension(2) :: fileOffset - - if(any(shape(dataset) == 0)) return - - vectorSize = size(dataset,1) - - call HDF5_addVectorDataset(group,dataspace_size,vectorSize,label,SIunit) ! here nNodes need to be global - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dopen_f') - - ! Define and select hyperslabs - counter(1) = vectorSize ! how big i am - counter(2) = size(dataset,2) - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = mpiOffset - - call h5screate_simple_f(2, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([vectorSize, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - -end subroutine HDF5_writeVectorDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new tensor dataset in the given group location -! by default, a 3x3 tensor is assumed !!!TODO: really necessary? -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeTensorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset - real(pReal), intent(in), dimension(:,:,:) :: dataset - - integer :: hdferr, tensorSize - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(3) :: counter - integer(HSSIZE_T), dimension(3) :: fileOffset - - if(any(shape(dataset) == 0)) return - - tensorSize = size(dataset,1) - - call HDF5_addTensor3DDataset(group,dataspace_size,tensorSize,label,SIunit) - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dopen_f') - - ! Define and select hyperslabs - counter(1) = tensorSize ! how big i am - counter(2) = tensorSize - counter(3) = size(dataset,3) - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = 0 - fileOffset(3) = mpiOffset - - call h5screate_simple_f(3, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([tensorSize, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - - end subroutine HDF5_writeTensorDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new vector dataset to the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addVectorDataset(group,nnodes,vectorSize,label,SIunit) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: nnodes,vectorSize - character(len=*), intent(in) :: SIunit,label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(2, int([vectorSize,Nnodes],HSIZE_T), space_id, hdferr, & - int([vectorSize,Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label), H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addVectorDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief writes to a new scalar dataset in the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeScalarDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset - real(pReal), intent(in), dimension(:) :: dataset - - integer :: hdferr, nNodes - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(1) :: counter - integer(HSIZE_T), dimension(1) :: fileOffset - - nNodes = size(dataset) - if (nNodes < 1) return - - call HDF5_addScalarDataset(group,dataspace_size,label,SIunit) - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dopen_f') - - ! Define and select hyperslabs - counter = size(dataset) ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - -end subroutine HDF5_writeScalarDataset !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of the type pReal with 1 dimension @@ -2280,62 +1076,5 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_HDF5_write_pInt7: h5sclose_f' end subroutine HDF5_write_pInt7 -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new scalar dataset to the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addScalarDataset(group,nnodes,label,SIunit) - use hdf5 - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: nnodes - character(len=*), intent(in) :: SIunit,label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & - int([Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addScalarDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief copies the current temp results to the actual results file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_forwardResults(time) - use hdf5 - use IO, only: & - IO_intOut - - implicit none - integer :: hdferr - integer(HID_T) :: currentIncID - real(pReal), intent(in) :: time - character(len=1024) :: myName - - currentInc = currentInc +1_pInt - write(6,*) 'forward results';flush(6) - write(myName,'(a,'//IO_intOut(currentInc)//')') 'inc',currentInc - currentIncID = HDF5_addGroup(myName) - call HDF5_setLink(myName,'current') -! call HDF5_flush(resultsFile) - call HDF5_closeGroup(currentIncID) - -end subroutine HDF5_forwardResults - -end module HDF5_Utilities \ No newline at end of file +end module HDF5_Utilities From 9b32fe6dbd2582893c83bd127d2b7ef070f83b74 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 15 Nov 2018 07:28:34 +0100 Subject: [PATCH 045/372] MPI file access needed for output --- src/HDF5_utilities.f90 | 59 ++++++++++++------------------------------ 1 file changed, 16 insertions(+), 43 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 1193eb25d..b1f32e805 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -4,7 +4,7 @@ !> @author Jennifer Nastola, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- -module HDF5_Utilities +module HDF5_utilities use prec use IO use HDF5 @@ -14,9 +14,6 @@ module HDF5_Utilities implicit none private - integer(HID_T), public, protected :: tempCoordinates, tempResults - integer(HID_T), private :: resultsFile, currentIncID, plist_id - integer(pInt), private :: currentInc !-------------------------------------------------------------------------------------------------- !> @brief reads pInt or pReal data of defined shape from file @@ -73,7 +70,7 @@ module HDF5_Utilities HDF5_write contains -subroutine HDF5_Utilities_init +subroutine HDF5_utilities_init use, intrinsic :: & iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) @@ -95,54 +92,21 @@ subroutine HDF5_Utilities_init if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)') if (int(pReal,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pReal does not match H5T_NATIVE_DOUBLE') -end subroutine HDF5_Utilities_init - - - - -!-------------------------------------------------------------------------------------------------- -!> @brief creates and initializes HDF5 output files -!-------------------------------------------------------------------------------------------------- - integer(HID_T) function HDF5_createFile(path) - use hdf5 - use DAMASK_interface, only: & - getSolverJobName - - implicit none - integer :: hdferr - integer(SIZE_T) :: typeSize - character(len=*), intent(in) :: path -#ifdef PETSc -#include -#endif - call h5open_f(hdferr) !############################################################ DANGEROUS -#ifdef PETSc - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') -#endif -!-------------------------------------------------------------------------------------------------- -! create a file - !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) - call h5fcreate_f(path,H5F_ACC_TRUNC_F,HDF5_createFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) - !call HDF5_addStringAttribute(HDF5_createFile,'createdBy',DAMASKVERSION) - call h5pclose_f(plist_id, hdferr) !neu - -end function HDF5_createFile - +end subroutine HDF5_utilities_init !-------------------------------------------------------------------------------------------------- !> @brief open and initializes HDF5 output file !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openFile(fileName,mode) +integer(HID_T) function HDF5_openFile(fileName,mode,parallel) implicit none character(len=*), intent(in) :: fileName character, intent(in), optional :: mode + logical, intent(in), optional :: parallel + character :: m + integer(HID_T) :: plist_id integer :: hdferr if (present(mode)) then @@ -151,6 +115,15 @@ integer(HID_T) function HDF5_openFile(fileName,mode) m = 'r' endif +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') + call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') + endif; endif +#endif + if (m == 'w') then call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) From d5963b403a98b410c18cadc44207c29b02e0b152 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 16 Nov 2018 07:05:43 +0100 Subject: [PATCH 046/372] setting the property when opening the file --- src/HDF5_utilities.f90 | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index b1f32e805..4c29fe980 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -115,28 +115,32 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) m = 'r' endif + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') + #ifdef PETSc if (present(parallel)) then; if (parallel) then - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') endif; endif #endif - if (m == 'w') then - call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) + if (m == 'w') then + call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) elseif(m == 'a') then - call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)',el=hdferr) + call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)',el=hdferr) elseif(m == 'r') then - call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)',el=hdferr) + call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)',el=hdferr) else - call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode',el=hdferr) + call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode') endif + call h5pclose_f(plist_id, hdferr) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') + end function HDF5_openFile From d8a425b4643be043eb2161b4f4c753b5197718e4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 17 Nov 2018 15:00:51 +0100 Subject: [PATCH 047/372] prevent error h5close_f will give an error if h5open_f was not called. according to the manual, calling h5open_f multiple time is not a problem --- src/quit.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/quit.f90 b/src/quit.f90 index 4219830a5..ad61943e4 100644 --- a/src/quit.f90 +++ b/src/quit.f90 @@ -23,6 +23,8 @@ subroutine quit(stop_id) integer(pInt) :: error = 0_pInt PetscErrorCode :: ierr = 0 + call h5open_f(hdferr) + if (hdferr /= 0) write(6,'(a,i5)') ' Error in h5open_f',hdferr ! prevents error if not opened yet call h5close_f(hdferr) if (hdferr /= 0) write(6,'(a,i5)') ' Error in h5close_f',hdferr From 73ca289322f38e748b71ba761e38cb69f6d01ee3 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 17 Nov 2018 16:50:19 +0100 Subject: [PATCH 048/372] F_aim was wrong in case of MPI parallelization --- src/spectral_mech_Basic.f90 | 5 +++++ src/spectral_mech_Polarisation.f90 | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/spectral_mech_Basic.f90 b/src/spectral_mech_Basic.f90 index d6f353c91..003c9820d 100644 --- a/src/spectral_mech_Basic.f90 +++ b/src/spectral_mech_Basic.f90 @@ -80,6 +80,7 @@ subroutine basic_init #endif use IO, only: & IO_intOut, & + IO_error, & IO_read_realFile, & IO_timeStamp use debug, only: & @@ -173,7 +174,11 @@ subroutine basic_init call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(F_aimDot)) read (777,rec=1) F_aimDot; close (777) F_aim = reshape(sum(sum(sum(F,dim=4),dim=3),dim=2) * wgt, [3,3]) ! average of F + call MPI_Allreduce(MPI_IN_PLACE,F_aim,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='F_aim') F_aim_lastInc = sum(sum(sum(F_lastInc,dim=5),dim=4),dim=3) * wgt ! average of F_lastInc + call MPI_Allreduce(MPI_IN_PLACE,F_aim_lastInc,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='F_aim_lastInc') elseif (restartInc == 0_pInt) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) diff --git a/src/spectral_mech_Polarisation.f90 b/src/spectral_mech_Polarisation.f90 index 04f51cb35..b1da2a3f0 100644 --- a/src/spectral_mech_Polarisation.f90 +++ b/src/spectral_mech_Polarisation.f90 @@ -78,7 +78,6 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all necessary fields and fills them with data, potentially from restart info -!> @todo use sourced allocation, e.g. allocate(Fdot,source = F_lastInc) !-------------------------------------------------------------------------------------------------- subroutine Polarisation_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 @@ -88,6 +87,7 @@ subroutine Polarisation_init #endif use IO, only: & IO_intOut, & + IO_error, & IO_read_realFile, & IO_timeStamp use debug, only: & @@ -191,7 +191,11 @@ subroutine Polarisation_init call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(F_aimDot)) read (777,rec=1) F_aimDot; close (777) F_aim = reshape(sum(sum(sum(F,dim=4),dim=3),dim=2) * wgt, [3,3]) ! average of F + call MPI_Allreduce(MPI_IN_PLACE,F_aim,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='F_aim') F_aim_lastInc = sum(sum(sum(F_lastInc,dim=5),dim=4),dim=3) * wgt ! average of F_lastInc + call MPI_Allreduce(MPI_IN_PLACE,F_aim_lastInc,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='F_aim_lastInc') elseif (restartInc == 0_pInt) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) From 8b1785c05ccca92fadb1339255bf2d13a334feec Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 09:47:50 +0100 Subject: [PATCH 049/372] parallel writing for pReal --- src/HDF5_utilities.f90 | 582 ++++++++++++++++++++++++++++++++--------- 1 file changed, 463 insertions(+), 119 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 4c29fe980..e36e39e29 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -542,265 +542,609 @@ subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) end subroutine HDF5_read_pInt_7 + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of the type pReal with 1 dimensions +!> @brief subroutine for writing dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal1(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 2 dimensions +!> @brief subroutine for writing dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal2(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 3 dimensions +!> @brief subroutine for writing dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal3(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 4 dimensions +!> @brief subroutine for writing dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal4(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 5 dimensions +!> @brief subroutine for writing dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal5(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 6 dimensions +!> @brief subroutine for writing dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal6(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 7 dimensions +!> @brief subroutine for writing dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal7(dataset,loc_id,datasetName) +subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- From 366c63e273c2d61779d5a6907c69c5d3b63f31c9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 11:21:43 +0100 Subject: [PATCH 050/372] CONFIG is a keyword for Cmake --- src/CMakeLists.txt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2e4462243..3bb72bb04 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -41,9 +41,9 @@ add_library(DEBUG OBJECT "debug.f90") add_dependencies(DEBUG NUMERICS) list(APPEND OBJECTFILES $) -add_library(CONFIG OBJECT "config.f90") -add_dependencies(CONFIG DEBUG) -list(APPEND OBJECTFILES $) +add_library(DAMASK_CONFIG OBJECT "config.f90") +add_dependencies(DAMASK_CONFIG DEBUG) +list(APPEND OBJECTFILES $) add_library(FEsolving OBJECT "FEsolving.f90") add_dependencies(FEsolving DEBUG) @@ -68,7 +68,7 @@ elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") endif() add_library(MATERIAL OBJECT "material.f90") -add_dependencies(MATERIAL MESH CONFIG) +add_dependencies(MATERIAL MESH DAMASK_CONFIG) list(APPEND OBJECTFILES $) add_library(DAMASK_HELPERS OBJECT "lattice.f90") From 35211a8468cb8028c19df0431d2d5b2eaa55b846 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 11:24:55 +0100 Subject: [PATCH 051/372] compilation order should reflect dependency --- src/CMakeLists.txt | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 3bb72bb04..6e5a808df 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -29,16 +29,16 @@ add_library(IO OBJECT "IO.f90") add_dependencies(IO DAMASK_INTERFACE) list(APPEND OBJECTFILES $) -add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") -add_dependencies(HDF5_UTILITIES IO) -list(APPEND OBJECTFILES $) - add_library(NUMERICS OBJECT "numerics.f90") -add_dependencies(NUMERICS HDF5_UTILITIES) +add_dependencies(NUMERICS IO) list(APPEND OBJECTFILES $) +add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") +add_dependencies(HDF5_UTILITIES NUMERICS) +list(APPEND OBJECTFILES $) + add_library(DEBUG OBJECT "debug.f90") -add_dependencies(DEBUG NUMERICS) +add_dependencies(DEBUG HDF5_UTILITIES) list(APPEND OBJECTFILES $) add_library(DAMASK_CONFIG OBJECT "config.f90") From fb5b1bfd8e6a5117c9a0f51e8b2765636b71ffcc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 11:32:53 +0100 Subject: [PATCH 052/372] compile results module --- src/CMakeLists.txt | 16 +- src/results.f90 | 919 +-------------------------------------------- 2 files changed, 17 insertions(+), 918 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 6e5a808df..90fb291fd 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -33,20 +33,24 @@ add_library(NUMERICS OBJECT "numerics.f90") add_dependencies(NUMERICS IO) list(APPEND OBJECTFILES $) -add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") -add_dependencies(HDF5_UTILITIES NUMERICS) -list(APPEND OBJECTFILES $) - add_library(DEBUG OBJECT "debug.f90") -add_dependencies(DEBUG HDF5_UTILITIES) +add_dependencies(DEBUG NUMERICS) list(APPEND OBJECTFILES $) add_library(DAMASK_CONFIG OBJECT "config.f90") add_dependencies(DAMASK_CONFIG DEBUG) list(APPEND OBJECTFILES $) +add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") +add_dependencies(HDF5_UTILITIES DAMASK_CONFIG) +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) +add_dependencies(FEsolving RESULTS) list(APPEND OBJECTFILES $) add_library(DAMASK_MATH OBJECT "math.f90") diff --git a/src/results.f90 b/src/results.f90 index 43a7a26e8..855fc5128 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -4,7 +4,7 @@ !> @author Jennifer Nastola, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- -module HDF5_Utilities +module results use prec use IO use HDF5 @@ -18,52 +18,9 @@ module HDF5_Utilities integer(HID_T), private :: resultsFile, currentIncID, plist_id integer(pInt), private :: currentInc -!-------------------------------------------------------------------------------------------------- -!> @brief reads pInt or pReal data of defined shape from file -!-------------------------------------------------------------------------------------------------- - interface HDF5_read - module procedure HDF5_read_pReal_1 - module procedure HDF5_read_pReal_2 - module procedure HDF5_read_pReal_3 - module procedure HDF5_read_pReal_4 - module procedure HDF5_read_pReal_5 - module procedure HDF5_read_pReal_6 - module procedure HDF5_read_pReal_7 - - module procedure HDF5_read_pInt_1 - module procedure HDF5_read_pInt_2 - module procedure HDF5_read_pInt_3 - module procedure HDF5_read_pInt_4 - module procedure HDF5_read_pInt_5 - module procedure HDF5_read_pInt_6 - module procedure HDF5_read_pInt_7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK - - end interface HDF5_read - -!-------------------------------------------------------------------------------------------------- -!> @brief writes pInt or pReal data of defined shape to file -!-------------------------------------------------------------------------------------------------- - interface HDF5_write - module procedure HDF5_write_pReal1 - module procedure HDF5_write_pReal2 - module procedure HDF5_write_pReal3 - module procedure HDF5_write_pReal4 - module procedure HDF5_write_pReal5 - module procedure HDF5_write_pReal6 - module procedure HDF5_write_pReal7 - - module procedure HDF5_write_pInt1 - module procedure HDF5_write_pInt2 - module procedure HDF5_write_pInt3 - module procedure HDF5_write_pInt4 - module procedure HDF5_write_pInt5 - module procedure HDF5_write_pInt6 - module procedure HDF5_write_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK - - end interface HDF5_write public :: & - HDF5_Utilities_init, & + results_init, & HDF5_mappingPhase, & HDF5_mappingHomog, & HDF5_mappingCrystallite, & @@ -83,38 +40,21 @@ module HDF5_Utilities HDF5_removeLink, & HDF5_createFile, & HDF5_closeFile, & - HDF5_addGroup2, & - HDF5_openFile, & - HDF5_read, & - HDF5_write + HDF5_addGroup2 contains -subroutine HDF5_Utilities_init +subroutine results_init use, intrinsic :: & iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) implicit none - integer :: hdferr - integer(SIZE_T) :: typeSize write(6,'(/,a)') ' <<<+- HDF5_Utilities init -+>>>' #include "compilation_info.f90" - !currentInc = -1_pInt ToDo - !call HDF5_createJobFile ToDo + currentInc = -1_pInt -!-------------------------------------------------------------------------------------------------- -!initialize HDF5 library and check if integer and float type size match - call h5open_f(hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5open_f') - call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)') - if (int(pInt,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pInt does not match H5T_NATIVE_INTEGER') - call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)') - if (int(pReal,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pReal does not match H5T_NATIVE_DOUBLE') - -end subroutine HDF5_Utilities_init +end subroutine results_init !-------------------------------------------------------------------------------------------------- !> @brief creates and initializes HDF5 output files @@ -1435,851 +1375,6 @@ subroutine HDF5_writeScalarDataset(group,dataset,label,SIunit,dataspace_size,mpi end subroutine HDF5_writeScalarDataset -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 1 dimension -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_1(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dclose_f') - -end subroutine HDF5_read_pReal_1 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_2(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dclose_f') - -end subroutine HDF5_read_pReal_2 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 3 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_3(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dclose_f') - -end subroutine HDF5_read_pReal_3 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 4 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_4(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dclose_f') - -end subroutine HDF5_read_pReal_4 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 5 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') - -end subroutine HDF5_read_pReal_5 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 6 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_6(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dclose_f') - -end subroutine HDF5_read_pReal_6 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 7 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_7(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dclose_f') - -end subroutine HDF5_read_pReal_7 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 1 dimension -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_1(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dclose_f') - -end subroutine HDF5_read_pInt_1 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_2(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dclose_f') - -end subroutine HDF5_read_pInt_2 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 3 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_3(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dclose_f') - -end subroutine HDF5_read_pInt_3 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 4 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_4(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dclose_f') - -end subroutine HDF5_read_pInt_4 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 5 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_5(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dclose_f') - -end subroutine HDF5_read_pInt_5 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 6 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_6(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dclose_f') - -end subroutine HDF5_read_pInt_6 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 7 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dclose_f') - -end subroutine HDF5_read_pInt_7 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of the type pReal with 1 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal1(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal2(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 3 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal3(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 4 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal4(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 5 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal5(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 6 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal6(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pReal with 7 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal7(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 1 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt1(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt2(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 3 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt3(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 4 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt4(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 5 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt5(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 6 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt6(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 7 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt7(dataset,loc_id,datasetName) - - implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - - integer(pInt), dimension(:), allocatable :: myShape ! @brief adds a new scalar dataset to the given group location !-------------------------------------------------------------------------------------------------- @@ -2338,4 +1433,4 @@ subroutine HDF5_forwardResults(time) end subroutine HDF5_forwardResults -end module HDF5_Utilities \ No newline at end of file +end module results From dfd624e520ca5b77660beb35a6b2a42208781ea7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 11:58:49 +0100 Subject: [PATCH 053/372] create results file --- src/CPFEM2.f90 | 3 + src/results.f90 | 209 ++++++------------------------------------------ 2 files changed, 29 insertions(+), 183 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 2aed858a7..126e9240b 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -39,6 +39,8 @@ subroutine CPFEM_initAll() material_init use HDF5_utilities, only: & HDF5_utilities_init + use results, only: & + results_init use lattice, only: & lattice_init use constitutive, only: & @@ -73,6 +75,7 @@ subroutine CPFEM_initAll() call lattice_init call material_init call HDF5_utilities_init + call results_init call constitutive_init call crystallite_init call homogenization_init diff --git a/src/results.f90 b/src/results.f90 index 855fc5128..f667edb10 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -8,6 +8,7 @@ module results use prec use IO use HDF5 + use HDF5_utilities #ifdef PETSc use PETSC #endif @@ -31,187 +32,29 @@ module results HDF5_addGroup ,& HDF5_closeGroup ,& HDF5_openGroup, & - HDF5_openGroup2, & HDF5_forwardResults, & HDF5_writeVectorDataset, & HDF5_writeScalarDataset, & HDF5_writeTensorDataset, & HDF5_closeJobFile, & - HDF5_removeLink, & - HDF5_createFile, & - HDF5_closeFile, & - HDF5_addGroup2 + HDF5_removeLink contains subroutine results_init use, intrinsic :: & iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) - + use DAMASK_interface, only: & + getSolverJobName implicit none - write(6,'(/,a)') ' <<<+- HDF5_Utilities init -+>>>' + write(6,'(/,a)') ' <<<+- results init -+>>>' #include "compilation_info.f90" currentInc = -1_pInt + call HDF5_closeFile(HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.)) end subroutine results_init -!-------------------------------------------------------------------------------------------------- -!> @brief creates and initializes HDF5 output files -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_createJobFile - use hdf5 - use DAMASK_interface, only: & - getSolverJobName - - implicit none - integer :: hdferr - character(len=1024) :: path -#ifdef PETSc -#include - - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! open file - path = trim(getSolverJobName())//'.'//'hdf5' - !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) - call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) - call HDF5_addStringAttribute(resultsFile,'createdBy',DAMASKVERSION) - call h5pclose_f(plist_id, hdferr) !neu - -end subroutine HDF5_createJobFile - - -!-------------------------------------------------------------------------------------------------- -!> @brief creates and initializes HDF5 output files -!-------------------------------------------------------------------------------------------------- - integer(HID_T) function HDF5_createFile(path) - use hdf5 - use DAMASK_interface, only: & - getSolverJobName - - implicit none - integer :: hdferr - integer(SIZE_T) :: typeSize - character(len=*), intent(in) :: path -#ifdef PETSc -#include -#endif - call h5open_f(hdferr) !############################################################ DANGEROUS -#ifdef PETSc - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pcreate_f') - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_Utilities_init: h5pset_fapl_mpio_f') -#endif -!-------------------------------------------------------------------------------------------------- -! create a file - !call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) - call h5fcreate_f(path,H5F_ACC_TRUNC_F,HDF5_createFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) - !call HDF5_addStringAttribute(HDF5_createFile,'createdBy',DAMASKVERSION) - call h5pclose_f(plist_id, hdferr) !neu - -end function HDF5_createFile - -!-------------------------------------------------------------------------------------------------- -!> @brief close the opened HDF5 output file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeJobFile() - use hdf5 - - implicit none - integer :: hdferr - call HDF5_removeLink('current') - call h5fclose_f(resultsFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f',el=hdferr) -! call h5close_f(hdferr) - -end subroutine HDF5_closeJobFile - -!-------------------------------------------------------------------------------------------------- -!> @brief open and initializes HDF5 output file -!-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openFile(fileName,mode) - - implicit none - character(len=*), intent(in) :: fileName - character, intent(in), optional :: mode - character :: m - integer :: hdferr - - if (present(mode)) then - m = mode - else - m = 'r' - endif - - if (m == 'w') then - call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) - elseif(m == 'a') then - call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)',el=hdferr) - elseif(m == 'r') then - call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)',el=hdferr) - else - call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode',el=hdferr) - endif - -end function HDF5_openFile - -!-------------------------------------------------------------------------------------------------- -!> @brief close the opened HDF5 output file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeFile(fileHandle) - - implicit none - integer :: hdferr - integer(HID_T), intent(in) :: fileHandle - call h5fclose_f(fileHandle,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f',el=hdferr) - -end subroutine HDF5_closeFile - -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new group to the results file -!-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup(groupName) - use hdf5 - - implicit none - character(len=*), intent(in) :: groupName - integer :: hdferr - - call h5gcreate_f(resultsFile, trim(groupName), HDF5_addGroup, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') - -end function HDF5_addGroup - - -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new group to the fileHandle (additional to addGroup2) -!-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup2(fileHandle,groupName) - use hdf5 - - implicit none - character(len=*), intent(in) :: groupName - integer(HID_T), intent(in) :: fileHandle - integer :: hdferr - - call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') - -end function HDF5_addGroup2 - !-------------------------------------------------------------------------------------------------- !> @brief open a group from the results file @@ -229,20 +72,34 @@ integer(HID_T) function HDF5_openGroup(groupName) end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- -!> @brief open an existing group of a file +!> @brief close the opened HDF5 output file !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) +subroutine HDF5_closeJobFile() + use hdf5 + + implicit none + integer :: hdferr + call HDF5_removeLink('current') + call h5fclose_f(resultsFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f',el=hdferr) +! call h5close_f(hdferr) + +end subroutine HDF5_closeJobFile + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the results file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_addGroup(groupName) use hdf5 implicit none character(len=*), intent(in) :: groupName integer :: hdferr - integer(HID_T), intent(in) :: FileReadID - call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5gopen_f ('//trim(groupName)//')') + call h5gcreate_f(resultsFile, trim(groupName), HDF5_addGroup, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') -end function HDF5_openGroup2 +end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file @@ -281,20 +138,6 @@ subroutine HDF5_removeLink(link) end subroutine HDF5_removeLink -!-------------------------------------------------------------------------------------------------- -!> @brief close a group -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeGroup(ID) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: ID - integer :: hdferr - - call h5gclose_f(ID, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(ID,pInt)) - -end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- !> @brief adds a StringAttribute to the results file From fcb14f6099478d7b0c22c6d1081458d20e9aed36 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 12:04:08 +0100 Subject: [PATCH 054/372] was never used --- processing/post/ascii2hdf5.py | 142 ---------------------------------- 1 file changed, 142 deletions(-) delete mode 100755 processing/post/ascii2hdf5.py diff --git a/processing/post/ascii2hdf5.py b/processing/post/ascii2hdf5.py deleted file mode 100755 index effac981b..000000000 --- a/processing/post/ascii2hdf5.py +++ /dev/null @@ -1,142 +0,0 @@ -#!/usr/bin/env python2.7 -# -*- coding: UTF-8 no BOM -*- - -# ------------------------------------------------------------------- # -# NOTE: # -# 1. Not all output is defined in the DS_HDF5.xml, please add new # -# new one to the system wide definition file # -# /lib/damask/DS_HDF5.xml # -# or specify your own when initializing HDF5 class # -# 2. Somehow the point cloud structure cannot be properly handled # -# by Xdmf, which is a descriptive wrapper for visualizing HDF5 # -# using Paraview. The current solution is using cell structured # -# HDF5 so that Xdmf can describe the data shape as a rectangular # -# mesh rather than polyvertex. # -# TODO: # -# 1. remove the ._tmp file, basically need a way to # -# just load data from ASCII table. # -# 2. a progress monitor when transferring data from ASCII table # -# to HDF5. # -# 3. a more flexible way handle the data structure rather than a # -# xml file. # -# ------------------------------------------------------------------- # - -import os -import damask -import numpy as np -from optparse import OptionParser - - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName, damask.version]) - - -# ----- helper function ----- # -def get_rectMshVectors(xyz_array, posNum): - """Get Vx, Vy, Vz for rectLinear grid""" - # need some improvement, and only works for rectangular grid - v = sorted(list(set(xyz_array[:, posNum]))) - v_interval = (v[2]+v[1])/2.0 - (v[1]+v[0])/2.0 - v_start = (v[1]+v[0])/2.0 - v_interval - v_end = (v[-1]+v[-2])/2.0 + v_interval - V = np.linspace(v_start, v_end, len(v)+1) - return V - - -# ----- MAIN ---- # -desp_msg = "Convert DAMASK ascii table to HDF5 file" -parser = OptionParser(option_class=damask.extendableOption, - usage='%prog options [file[s]]', - description=desp_msg, - version=scriptID) -parser.add_option('-D', '--DefinitionFile', - dest='storage definition file', - type='string', - metavar='string', - help='definition file for H5 data storage') -parser.add_option('-p', '--pos', '--position', - dest='pos', - type='string', metavar='string', - help='label of coordinates [%default]') - -parser.set_defaults(DefinitionFile='default', - pos='pos') - -(options, filenames) = parser.parse_args() - -filename = filenames[0] - -if options.DefinitionFile == 'default': - defFile = None -else: - defFile = options.DefinitionFile - -# ----- read in data using DAMASK ASCII table class ----- # -asciiTable = damask.ASCIItable(name=filename, buffered=False) -asciiTable.head_read() -asciiTable.data_readArray() -incNum = int(asciiTable.data[asciiTable.label_index('inc'), 0]) -fullTable = np.copy(asciiTable.data) # deep copy all data, just to be safe -labels = asciiTable.labels() -labels_idx = [asciiTable.label_index(label) for label in labels] -featuresDim = [labels_idx[i+1] - labels_idx[i] for i in range(len(labels)-1)] -featuresDim.append(fullTable.shape[1] - labels_idx[-1]) - -# ----- figure out size and grid ----- # -pos_idx = asciiTable.label_index('pos') -xyz_array = asciiTable.data[:, pos_idx:pos_idx+3] -Vx = get_rectMshVectors(xyz_array, 0) -Vy = get_rectMshVectors(xyz_array, 1) -Vz = get_rectMshVectors(xyz_array, 2) -# use the dimension of the rectangular grid to reshape all other data -mshGridDim = [len(Vx)-1, len(Vy)-1, len(Vz)-1] - -# ----- compose cmd log ----- # -cmd_log = " ".join([scriptID, filename]) - -# ----- create a new HDF5 file and save the data -----# -# force remove existing HDF5 file -h5fName = filename.replace(".txt", ".h5") -try: - os.remove(h5fName) -except OSError: - pass -h5f = damask.H5Table(h5fName, - new_file=True, - dsXMLFile=defFile) -# adding increment number as root level attributes -h5f.add_attr('inc', incNum) -# add the mesh grid data now -h5f.add_data("Vx", Vx, cmd_log=cmd_log) -h5f.add_data("Vy", Vy, cmd_log=cmd_log) -h5f.add_data("Vz", Vz, cmd_log=cmd_log) - -# add the rest of data from table -labelsProcessed = ['inc'] -for fi in range(len(labels)): - featureName = labels[fi] - # remove trouble maker "("" and ")" from label/feature name - if "(" in featureName: - featureName = featureName.replace("(", "") - if ")" in featureName: - featureName = featureName.replace(")", "") - # skip increment and duplicated columns in the ASCII table - if featureName in labelsProcessed: - continue - - featureIdx = labels_idx[fi] - featureDim = featuresDim[fi] - # grab the data hook - dataset = fullTable[:, featureIdx:featureIdx+featureDim] - # mapping 2D data onto a 3D rectangular mesh to get 4D data - # WARNING: In paraview, the data for a recmesh is mapped as: - # --> len(z), len(y), len(x), size(data) - # dataset = dataset.reshape((mshGridDim[0], - # mshGridDim[1], - # mshGridDim[2], - # dataset.shape[1])) - # write out data - print("adding {}...".format(featureName)) - h5f.add_data(featureName, dataset, cmd_log=cmd_log) - # write down the processed label - labelsProcessed.append(featureName) From 2be01e7bea6c5b5aba08d86aedbb681c9288cb9c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 12:04:49 +0100 Subject: [PATCH 055/372] results files should not be part of the repository --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 22c568409..2a118ef29 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.pyc *.mod *.o +*.hdf5 *.exe *.bak *~ From dd6f6bba9d108dbf294c6772b397360585d43b79 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 12:41:05 +0100 Subject: [PATCH 056/372] planning the forwarding of the results --- src/DAMASK_spectral.f90 | 5 ++ src/HDF5_utilities.f90 | 71 ++++++++++++++++++++++++- src/results.f90 | 112 ++++++++++++++-------------------------- 3 files changed, 113 insertions(+), 75 deletions(-) diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 index d6827543a..1e75f2761 100644 --- a/src/DAMASK_spectral.f90 +++ b/src/DAMASK_spectral.f90 @@ -80,6 +80,7 @@ program DAMASK_spectral use spectral_mech_Polarisation use spectral_damage use spectral_thermal + use results implicit none @@ -157,6 +158,10 @@ program DAMASK_spectral write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" + + call results_openJobFile() + call results_addIncrement() + call results_closeJobFile() !-------------------------------------------------------------------------------------------------- ! initialize field solver information nActiveFields = 1 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index e36e39e29..bef73f30f 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -61,11 +61,13 @@ module HDF5_utilities public :: & HDF5_utilities_init, & + HDF5_openFile, & + HDF5_closeFile, & + HDF5_addStringAttribute, & + HDF5_addIntegerAttribute, & HDF5_closeGroup ,& HDF5_openGroup2, & - HDF5_closeFile, & HDF5_addGroup2, & - HDF5_openFile, & HDF5_read, & HDF5_write contains @@ -208,6 +210,71 @@ subroutine HDF5_closeGroup(ID) end subroutine HDF5_closeGroup +!-------------------------------------------------------------------------------------------------- +!> @brief adds a StringAttribute to the results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: entity + character(len=*), intent(in) :: attrLabel, attrValue + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5screate_f') + call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tcopy_f') + call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tset_size_f') + call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5acreate_f') + call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5sclose_f') + +end subroutine HDF5_addStringAttribute + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a StringAttribute to the results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: entity + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in) :: attrValue + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5screate_f') + call h5tcopy_f(H5T_NATIVE_Integer, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tcopy_f') + call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tset_size_f') + call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5acreate_f') + call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5sclose_f') + +end subroutine HDF5_addIntegerAttribute + + !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of the type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- diff --git a/src/results.f90 b/src/results.f90 index f667edb10..2a695c55c 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -17,11 +17,13 @@ module results private integer(HID_T), public, protected :: tempCoordinates, tempResults integer(HID_T), private :: resultsFile, currentIncID, plist_id - integer(pInt), private :: currentInc public :: & results_init, & + results_openJobFile, & + results_closeJobFile, & + results_addIncrement, & HDF5_mappingPhase, & HDF5_mappingHomog, & HDF5_mappingCrystallite, & @@ -32,11 +34,9 @@ module results HDF5_addGroup ,& HDF5_closeGroup ,& HDF5_openGroup, & - HDF5_forwardResults, & HDF5_writeVectorDataset, & HDF5_writeScalarDataset, & HDF5_writeTensorDataset, & - HDF5_closeJobFile, & HDF5_removeLink contains @@ -50,12 +50,47 @@ subroutine results_init write(6,'(/,a)') ' <<<+- results init -+>>>' #include "compilation_info.f90" - currentInc = -1_pInt call HDF5_closeFile(HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.)) end subroutine results_init +!-------------------------------------------------------------------------------------------------- +!> @brief opens the results file to append data +!-------------------------------------------------------------------------------------------------- +subroutine results_openJobFile() + use DAMASK_interface, only: & + getSolverJobName + implicit none + + resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) + +end subroutine results_openJobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief closes the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_closeJobFile() + use DAMASK_interface, only: & + getSolverJobName + implicit none + + call HDF5_closeFile(resultsFile) + +end subroutine results_closeJobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief closes the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addIncrement() + implicit none + + call HDF5_addIntegerAttribute(resultsFile,'test',1) + +end subroutine results_addIncrement + !-------------------------------------------------------------------------------------------------- !> @brief open a group from the results file !-------------------------------------------------------------------------------------------------- @@ -71,20 +106,6 @@ integer(HID_T) function HDF5_openGroup(groupName) end function HDF5_openGroup -!-------------------------------------------------------------------------------------------------- -!> @brief close the opened HDF5 output file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeJobFile() - use hdf5 - - implicit none - integer :: hdferr - call HDF5_removeLink('current') - call h5fclose_f(resultsFile,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f',el=hdferr) -! call h5close_f(hdferr) - -end subroutine HDF5_closeJobFile !-------------------------------------------------------------------------------------------------- !> @brief adds a new group to the results file @@ -139,37 +160,6 @@ subroutine HDF5_removeLink(link) end subroutine HDF5_removeLink -!-------------------------------------------------------------------------------------------------- -!> @brief adds a StringAttribute to the results file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: entity - character(len=*), intent(in) :: attrLabel, attrValue - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5screate_f') - call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tcopy_f') - call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tset_size_f') - call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5acreate_f') - call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5sclose_f') - -end subroutine HDF5_addStringAttribute - !-------------------------------------------------------------------------------------------------- !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- @@ -1252,28 +1242,4 @@ subroutine HDF5_addScalarDataset(group,nnodes,label,SIunit) end subroutine HDF5_addScalarDataset -!-------------------------------------------------------------------------------------------------- -!> @brief copies the current temp results to the actual results file -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_forwardResults(time) - use hdf5 - use IO, only: & - IO_intOut - - implicit none - integer :: hdferr - integer(HID_T) :: currentIncID - real(pReal), intent(in) :: time - character(len=1024) :: myName - - currentInc = currentInc +1_pInt - write(6,*) 'forward results';flush(6) - write(myName,'(a,'//IO_intOut(currentInc)//')') 'inc',currentInc - currentIncID = HDF5_addGroup(myName) - call HDF5_setLink(myName,'current') -! call HDF5_flush(resultsFile) - call HDF5_closeGroup(currentIncID) - -end subroutine HDF5_forwardResults - end module results From 2b96ea3da52a4987b6d1976ab3d2b2d2f477975b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 18 Nov 2018 20:17:07 +0100 Subject: [PATCH 057/372] testing restart with MPI --- .gitlab-ci.yml | 9 +++++++++ PRIVATE | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5fafb19c0..186e73dc5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -321,6 +321,15 @@ Spectral_MPI: - master - release +SpectralAll_restartMPI: + stage: spectral + script: + - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel + - SpectralAll_restartMPI/test.py + except: + - master + - release + Plasticity_DetectChanges: stage: spectral script: Plasticity_DetectChanges/test.py diff --git a/PRIVATE b/PRIVATE index ee5a63d34..d3bc62220 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit ee5a63d34abbac295207354fddf30e6d7cc258cd +Subproject commit d3bc62220544da0a3198c521e0f73fa07898d357 From c0481307ee166ede1432565d5d5b914c5ba45eb3 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Tue, 20 Nov 2018 11:54:51 +0100 Subject: [PATCH 058/372] Changed the intent of input argument of dataset to inout --- src/HDF5_utilities.f90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index bef73f30f..c44b56729 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -619,7 +619,7 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:) :: dataset + real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -705,7 +705,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:) :: dataset + real(pReal), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -791,7 +791,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -877,7 +877,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -963,7 +963,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1049,7 +1049,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1135,7 +1135,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1218,7 +1218,7 @@ end subroutine HDF5_write_pReal7 subroutine HDF5_write_pInt1(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:) :: dataset + integer(pInt), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1254,7 +1254,7 @@ end subroutine HDF5_write_pInt1 subroutine HDF5_write_pInt2(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1290,7 +1290,7 @@ end subroutine HDF5_write_pInt2 subroutine HDF5_write_pInt3(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1326,7 +1326,7 @@ end subroutine HDF5_write_pInt3 subroutine HDF5_write_pInt4(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1362,7 +1362,7 @@ end subroutine HDF5_write_pInt4 subroutine HDF5_write_pInt5(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1434,7 +1434,7 @@ end subroutine HDF5_write_pInt6 subroutine HDF5_write_pInt7(dataset,loc_id,datasetName) implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file From 50a1ba62876cc7ed8a3ab5c09811956e125435f7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 20 Nov 2018 15:26:49 +0100 Subject: [PATCH 059/372] hdferr needs to be integer type during compile time of HDF5 library --- src/HDF5_utilities.f90 | 114 ++++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 54 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c44b56729..f30781fc7 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -14,6 +14,8 @@ module HDF5_utilities implicit none private + integer(pInt), parameter, private :: & + HDF5_ERR_TYPE = 4_pInt !< kind of the integer return in the HDF5 library !-------------------------------------------------------------------------------------------------- !> @brief reads pInt or pReal data of defined shape from file @@ -77,8 +79,8 @@ subroutine HDF5_utilities_init iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) implicit none - integer :: hdferr - integer(SIZE_T) :: typeSize + integer(HDF5_ERR_TYPE) :: hdferr + integer(SIZE_T) :: typeSize write(6,'(/,a)') ' <<<+- HDF5_Utilities init -+>>>' #include "compilation_info.f90" @@ -109,7 +111,7 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) character :: m integer(HID_T) :: plist_id - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr if (present(mode)) then m = mode @@ -129,13 +131,13 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) if (m == 'w') then call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f',el=hdferr) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f') elseif(m == 'a') then call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)',el=hdferr) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') elseif(m == 'r') then call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)',el=hdferr) + if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') else call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode') endif @@ -152,10 +154,11 @@ end function HDF5_openFile subroutine HDF5_closeFile(fileHandle) implicit none - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: fileHandle + call h5fclose_f(fileHandle,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f',el=hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') end subroutine HDF5_closeFile @@ -164,12 +167,11 @@ end subroutine HDF5_closeFile !> @brief adds a new group to the fileHandle (additional to addGroup2) !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_addGroup2(fileHandle,groupName) - use hdf5 implicit none character(len=*), intent(in) :: groupName integer(HID_T), intent(in) :: fileHandle - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') @@ -181,11 +183,10 @@ end function HDF5_addGroup2 !> @brief open an existing group of a file !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) - use hdf5 implicit none character(len=*), intent(in) :: groupName - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: FileReadID call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr) @@ -198,11 +199,10 @@ end function HDF5_openGroup2 !> @brief close a group !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeGroup(ID) - use hdf5 implicit none integer(HID_T), intent(in) :: ID - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr call h5gclose_f(ID, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(ID,pInt)) @@ -214,12 +214,11 @@ end subroutine HDF5_closeGroup !> @brief adds a StringAttribute to the results file !-------------------------------------------------------------------------------------------------- subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) - use hdf5 implicit none integer(HID_T), intent(in) :: entity character(len=*), intent(in) :: attrLabel, attrValue - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: attr_id, space_id, type_id call h5screate_f(H5S_SCALAR_F,space_id,hdferr) @@ -246,13 +245,12 @@ end subroutine HDF5_addStringAttribute !> @brief adds a StringAttribute to the results file !-------------------------------------------------------------------------------------------------- subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) - use hdf5 implicit none integer(HID_T), intent(in) :: entity character(len=*), intent(in) :: attrLabel integer(pInt), intent(in) :: attrValue - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: attr_id, space_id, type_id call h5screate_f(H5S_SCALAR_F,space_id,hdferr) @@ -285,7 +283,7 @@ subroutine HDF5_read_pReal_1(dataset,loc_id,datasetName) integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -309,8 +307,8 @@ subroutine HDF5_read_pReal_2(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr - integer(HID_T) :: dset_id + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) @@ -332,7 +330,7 @@ subroutine HDF5_read_pReal_3(dataset,loc_id,datasetName) integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -356,7 +354,7 @@ subroutine HDF5_read_pReal_4(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -380,7 +378,7 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -404,7 +402,7 @@ subroutine HDF5_read_pReal_6(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -428,7 +426,7 @@ subroutine HDF5_read_pReal_7(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -452,7 +450,7 @@ subroutine HDF5_read_pInt_1(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -476,7 +474,7 @@ subroutine HDF5_read_pInt_2(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -500,7 +498,7 @@ subroutine HDF5_read_pInt_3(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -524,7 +522,7 @@ subroutine HDF5_read_pInt_4(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -548,7 +546,7 @@ subroutine HDF5_read_pInt_5(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -572,7 +570,7 @@ subroutine HDF5_read_pInt_6(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -596,7 +594,7 @@ subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer :: hdferr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id myShape = shape(dataset) @@ -629,11 +627,12 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(1) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -715,11 +714,12 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(2) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -801,11 +801,12 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(3) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -887,11 +888,12 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(4) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -973,11 +975,12 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(5) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -1059,11 +1062,12 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(6) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -1145,11 +1149,12 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes - integer :: hdferr,ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(7) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- ! determine shape of dataset @@ -1223,7 +1228,8 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt), dimension(:), allocatable :: myShape ! Date: Tue, 20 Nov 2018 15:27:32 +0100 Subject: [PATCH 060/372] respect dependencies of inclusion --- src/commercialFEM_fileList.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 36f0244ef..7ab022d5a 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -4,12 +4,12 @@ !> @details List of files needed by MSC.Marc, Abaqus/Explicit, and Abaqus/Standard !-------------------------------------------------------------------------------------------------- #include "IO.f90" -#ifdef DAMASKHDF5 -#include "HDF5_utilities.f90" -#endif #include "numerics.f90" #include "debug.f90" #include "config.f90" +#ifdef DAMASKHDF5 +#include "HDF5_utilities.f90" +#endif #include "math.f90" #include "FEsolving.f90" #include "mesh.f90" From 32b62da84f2336b22cc407a04ab9d7cf6c54fe45 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 20 Nov 2018 16:05:59 +0100 Subject: [PATCH 061/372] compile MSC.Marc with HDF5 --- .../2018.1/Marc_tools/include_linux64 | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 index 22b306cb1..53052b065 100644 --- a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 @@ -63,7 +63,14 @@ else INTEGER_PATH=/$MARC_INTEGER_SIZE fi -FCOMP=ifort +if test "$DAMASK_HDF5" = "ON";then + H5FC="$(h5fc -show)" + HDF5_LIB=${$H5FC//ifort/} + FCOMP=$H5FC +else + FCOMP=ifort +fi + INTELPATH="/opt/intel/compilers_and_libraries_2017/linux" # find the root directory of the compiler installation: @@ -535,23 +542,17 @@ else DAMASKVERSION="'N/A'" fi -if test "$DAMASK_HDF5" = "ON";then - DFCOMP="$(h5fc -show) -DDAMASKHDF5" -else - DFCOMP=$FCOMP -fi -# # DAMASK compiler calls: additional flags are in line 2 OpenMP flags in line 3 -DFORTLOWMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" -DFORTRANMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" -DFORTHIGHMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" @@ -570,15 +571,15 @@ then fi # DAMASK compiler calls: additional flags are in line 2 OpenMP flags in line 3 - DFORTLOWMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" - DFORTRANMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" - DFORTHIGHMP="$DFCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018.1 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" @@ -744,7 +745,7 @@ SECLIBS="-L$MARC_LIB -llapi" SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \ $MKLLIB -L$MARC_MKL -liomp5 \ - $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a " + $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a $HDF5_LIB " SOLVERLIBS_DLL=${SOLVERLIBS} if test "$AEM_DLL" -eq 1 From aea5730c940b3682315bbef08cae300e88f15569 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 20 Nov 2018 21:54:55 +0100 Subject: [PATCH 062/372] don't disturb the search routines of MSC.Marc --- .../2018.1/Marc_tools/include_linux64 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 index 53052b065..53eef9d83 100644 --- a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 @@ -63,14 +63,6 @@ else INTEGER_PATH=/$MARC_INTEGER_SIZE fi -if test "$DAMASK_HDF5" = "ON";then - H5FC="$(h5fc -show)" - HDF5_LIB=${$H5FC//ifort/} - FCOMP=$H5FC -else - FCOMP=ifort -fi - INTELPATH="/opt/intel/compilers_and_libraries_2017/linux" # find the root directory of the compiler installation: @@ -106,6 +98,16 @@ else FCOMPROOT= fi +# DAMASK uses the HDF5 compiler wrapper around the Intel compiler +if test "$DAMASK_HDF5" = "ON";then + H5FC="$(h5fc -shlib -show)" + HDF5_LIB=${H5FC//ifort/} + FCOMP="$H5FC -DDAMASKHDF5" + echo $FCOMP +else + FCOMP=ifort +fi + # AEM if test "$MARCDLLOUTDIR" = ""; then DLLOUTDIR="$MARC_LIB" From d110534eca8cb63c56f969fcc0d496836c37ce51 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 20 Nov 2018 22:00:08 +0100 Subject: [PATCH 063/372] draft (no license for checking) --- installation/mods_Abaqus/abaqus_v6.env | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index d09257a9d..33c13c2ee 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -12,9 +12,15 @@ # import os, re, glob, driverUtils from damask import version as DAMASKVERSION +from damask import Environment +myEnv = damask.Environment() -# Use the version in $PATH -fortCmd = "ifort" +if myEnv.options['DAMASK_HDF5'] == 'ON': + # use hdf5 compiler wrapper in $PATH + fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') +else + # Use the version in $PATH + fortCmd = "ifort" # -free to use free-format FORTRAN 90 syntax # -O <0-3> optimization level From f51aafabdd832b4e01b8a8dad19d4662488a7686 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 21 Nov 2018 00:00:18 +0100 Subject: [PATCH 064/372] using hdf5 wrapper for compilation of subroutines --- installation/mods_Abaqus/abaqus_v6.env | 10 +++++++--- installation/mods_Abaqus/abaqus_v6_debug.env | 14 ++++++++++++-- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index 33c13c2ee..0b4a7fd43 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -13,12 +13,14 @@ import os, re, glob, driverUtils from damask import version as DAMASKVERSION from damask import Environment -myEnv = damask.Environment() +myEnv = Environment() if myEnv.options['DAMASK_HDF5'] == 'ON': # use hdf5 compiler wrapper in $PATH - fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') -else + fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string + link_sl += fortCmd.split()[1:] + fortCmd +=" -DDAMASKHDF5" +else: # Use the version in $PATH fortCmd = "ifort" @@ -56,4 +58,6 @@ ask_delete=OFF # Remove the temporary names from the namespace del fortCmd +del Environment +del myEnv del DAMASKVERSION diff --git a/installation/mods_Abaqus/abaqus_v6_debug.env b/installation/mods_Abaqus/abaqus_v6_debug.env index de5189a52..c967c1e65 100644 --- a/installation/mods_Abaqus/abaqus_v6_debug.env +++ b/installation/mods_Abaqus/abaqus_v6_debug.env @@ -12,9 +12,17 @@ # import os, re, glob, driverUtils from damask import version as DAMASKVERSION +from damask import Environment +myEnv = Environment() -# Use the version in $PATH -fortCmd = "ifort" +if myEnv.options['DAMASK_HDF5'] == 'ON': + # 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:] + fortCmd +=" -DDAMASKHDF5" +else: + # Use the version in $PATH + fortCmd = "ifort" # -free to use free-format FORTRAN 90 syntax # -O <0-3> optimization level @@ -55,4 +63,6 @@ ask_delete=OFF # Remove the temporary names from the namespace del fortCmd +del Environment +del myEnv del DAMASKVERSION From d00e3105ed655f68a5a4baba9faf70e3cd8f1f6d Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Wed, 21 Nov 2018 16:10:17 +0100 Subject: [PATCH 065/372] Made hdferr < 0 and removed the unnecessary call to h5getspace in hyperslab --- src/HDF5_utilities.f90 | 250 +++++++++++++++++++---------------------- 1 file changed, 118 insertions(+), 132 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index f30781fc7..c0ee3d472 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -120,30 +120,30 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) endif call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') endif; endif #endif if (m == 'w') then call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f') elseif(m == 'a') then call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') elseif(m == 'r') then call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') else call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode') endif call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') end function HDF5_openFile @@ -288,11 +288,11 @@ subroutine HDF5_read_pReal_1(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dclose_f') end subroutine HDF5_read_pReal_1 @@ -312,11 +312,11 @@ subroutine HDF5_read_pReal_2(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dclose_f') end subroutine HDF5_read_pReal_2 @@ -335,11 +335,11 @@ subroutine HDF5_read_pReal_3(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dclose_f') end subroutine HDF5_read_pReal_3 @@ -359,11 +359,11 @@ subroutine HDF5_read_pReal_4(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dclose_f') end subroutine HDF5_read_pReal_4 @@ -383,11 +383,11 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') end subroutine HDF5_read_pReal_5 @@ -407,11 +407,11 @@ subroutine HDF5_read_pReal_6(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dclose_f') end subroutine HDF5_read_pReal_6 @@ -431,11 +431,11 @@ subroutine HDF5_read_pReal_7(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dclose_f') end subroutine HDF5_read_pReal_7 @@ -455,11 +455,11 @@ subroutine HDF5_read_pInt_1(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dclose_f') end subroutine HDF5_read_pInt_1 @@ -479,11 +479,11 @@ subroutine HDF5_read_pInt_2(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dclose_f') end subroutine HDF5_read_pInt_2 @@ -503,11 +503,11 @@ subroutine HDF5_read_pInt_3(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dclose_f') end subroutine HDF5_read_pInt_3 @@ -527,11 +527,11 @@ subroutine HDF5_read_pInt_4(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dclose_f') end subroutine HDF5_read_pInt_4 @@ -551,11 +551,11 @@ subroutine HDF5_read_pInt_5(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dclose_f') end subroutine HDF5_read_pInt_5 @@ -575,11 +575,11 @@ subroutine HDF5_read_pInt_6(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dclose_f') end subroutine HDF5_read_pInt_6 @@ -599,11 +599,11 @@ subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) myShape = shape(dataset) call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dopen_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dread_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dread_f') call h5dclose_f(dset_id,hdferr) - if (hdferr /= 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dclose_f') + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dclose_f') end subroutine HDF5_read_pInt_7 @@ -642,7 +642,7 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') endif; endif @@ -655,42 +655,40 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal1 @@ -729,7 +727,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') endif; endif @@ -742,42 +740,40 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal2 @@ -816,7 +812,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') endif; endif @@ -829,42 +825,40 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal3 @@ -903,7 +897,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') endif; endif @@ -916,42 +910,40 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal4 @@ -990,7 +982,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') endif; endif @@ -1003,42 +995,40 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal5 @@ -1077,7 +1067,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') endif; endif @@ -1090,42 +1080,40 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal6 @@ -1164,7 +1152,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') endif; endif @@ -1177,42 +1165,40 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/filespace_id') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dget_space_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr /= 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal7 From 5cc6d86c6104f4ae4b3c23c69c12093cdc649af8 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Wed, 21 Nov 2018 16:57:36 +0100 Subject: [PATCH 066/372] Added the parallelized functionality for integer datatypes (works for groups?) --- src/HDF5_utilities.f90 | 563 +++++++++++++++++++++++++++++++++-------- 1 file changed, 457 insertions(+), 106 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c0ee3d472..c6543ffa4 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -1206,255 +1206,606 @@ end subroutine HDF5_write_pReal7 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of the type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt1(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 2 dimensions +!> @brief subroutine for writing dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt2(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 3 dimensions +!> @brief subroutine for writing dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt3(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 4 dimensions +!> @brief subroutine for writing dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt4(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 5 dimensions +!> @brief subroutine for writing dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt5(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 6 dimensions +!> @brief subroutine for writing dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt6(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! @brief subroutine for writing dataset of the type pInt with 7 dimensions +!> @brief subroutine for writing dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt7(dataset,loc_id,datasetName) +subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: myShape ! Date: Wed, 21 Nov 2018 19:35:37 +0100 Subject: [PATCH 067/372] Parallel works for groups and included write function for integer data --- src/HDF5_utilities.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c6543ffa4..cda585363 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -166,13 +166,17 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- !> @brief adds a new group to the fileHandle (additional to addGroup2) !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup2(fileHandle,groupName) +integer(HID_T) function HDF5_addGroup2(fileHandle,groupName,parallel) implicit none character(len=*), intent(in) :: groupName integer(HID_T), intent(in) :: fileHandle integer(HDF5_ERR_TYPE) :: hdferr + logical,intent(in), optional :: parallel + + integer(HID_T) :: plist_id,gapl_id + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') From 8b4781cf285f9d8f74b56b14fbdd3d48655556b6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 23 Nov 2018 05:37:31 +0100 Subject: [PATCH 068/372] no need to repeat code --- src/constitutive.f90 | 3 +- src/plastic_kinematichardening.f90 | 53 +++++++++--------------------- 2 files changed, 16 insertions(+), 40 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index c4d2cacbf..820715d80 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -516,8 +516,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e call plastic_phenopowerlaw_LpAndItsTangent (Lp,dLp_dMp, Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp),ipc,ip,el) - dLp_dMp = math_Plain99to3333(dLp_dMp99) ! ToDo: We revert here the last statement in plastic_xx_LpAndItsTanget + call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, math_Mandel33to6(Mp),ipc,ip,el) case (PLASTICITY_NONLOCAL_ID) plasticityType call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp), & diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 5089cd5ca..2eb6ac4aa 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -140,18 +140,17 @@ subroutine plastic_kinehardening_init(fileUnit) IO_timeStamp, & IO_EOF use material, only: & - PLASTICITY_kinehardening_label, & - PLASTICITY_kinehardening_ID, & phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & + material_allocatePlasticState, & + PLASTICITY_kinehardening_label, & + PLASTICITY_kinehardening_ID, & material_phase, & plasticState use config, only: & MATERIAL_partPhase use lattice - use numerics,only: & - numerics_integrator implicit none integer(pInt), intent(in) :: fileUnit @@ -422,29 +421,11 @@ subroutine plastic_kinehardening_init(fileUnit) + nSlip !< accumulated shear at last switch of stress sense sizeState = sizeDotState + sizeDeltaState - plasticState(phase)%sizeState = sizeState - plasticState(phase)%sizeDotState = sizeDotState - plasticState(phase)%sizeDeltaState = sizeDeltaState - plasticState(phase)%offsetDeltaState = sizeDotState - plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) - plasticState(phase)%nSlip = nSlip - - allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%state ( sizeState,NipcMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%aTolState (sizeDotState), source=0.0_pReal) - allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase), source=0.0_pReal) ! allocate space for deltaState - if (any(numerics_integrator == 1_pInt)) then - allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase), source=0.0_pReal) + call material_allocatePlasticState(phase,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & + nSlip,0_pInt,0_pInt) + plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) + offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt plasticState(phase)%slipRate => & plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) @@ -611,7 +592,7 @@ end subroutine plastic_kinehardening_shearRates !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & +subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & Tstar_v,ipc,ip,el) use prec, only: & dNeq0 @@ -639,8 +620,8 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(9,9), intent(out) :: & - dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLp_dMp !< derivative of Lp with respect to the Mandel stress integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point @@ -661,8 +642,6 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & tau_pos,tau_neg real(pReal) :: & dgdot_dtau_pos,dgdot_dtau_neg - real(pReal), dimension(3,3,3,3) :: & - dLp_dTstar3333 !< derivative of Lp with respect to Tstar as 4th order tensor real(pReal), dimension(3,3,2) :: & nonSchmid_tensor @@ -671,8 +650,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & instance = phase_plasticityInstance(ph) Lp = 0.0_pReal - dLp_dTstar3333 = 0.0_pReal - dLp_dTstar99 = 0.0_pReal + dLp_dMp = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Tstar_v,ph,instance,of) @@ -702,22 +680,21 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & if (dNeq0(gdot_pos(j))) then dgdot_dtau_pos = gdot_pos(j)*param(instance)%n_slip/(tau_pos(j)-state(instance)%crss_back(j,of)) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dTstar3333(k,l,m,n) = & - dLp_dTstar3333(k,l,m,n) + dgdot_dtau_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + dLp_dMp(k,l,m,n) = & + dLp_dMp(k,l,m,n) + dgdot_dtau_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & nonSchmid_tensor(m,n,1) endif if (dNeq0(gdot_neg(j))) then dgdot_dtau_neg = gdot_neg(j)*param(instance)%n_slip/(tau_neg(j)-state(instance)%crss_back(j,of)) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dTstar3333(k,l,m,n) = & - dLp_dTstar3333(k,l,m,n) + dgdot_dtau_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + dLp_dMp(k,l,m,n) = & + dLp_dMp(k,l,m,n) + dgdot_dtau_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & nonSchmid_tensor(m,n,2) endif enddo slipSystems enddo slipFamilies - dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) end subroutine plastic_kinehardening_LpAndItsTangent From 6df68d9428b3b9f16da40a4275dc9406242f1ae1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 23 Nov 2018 06:04:39 +0100 Subject: [PATCH 069/372] no need do constantly convert 3x3 matrix <-> 6 vector --- src/constitutive.f90 | 8 ++--- src/plastic_kinematichardening.f90 | 52 ++++++++++++++++-------------- 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 820715d80..6fd0161f9 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -516,7 +516,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e call plastic_phenopowerlaw_LpAndItsTangent (Lp,dLp_dMp, Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, math_Mandel33to6(Mp),ipc,ip,el) + call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, Mp,ipc,ip,el) case (PLASTICITY_NONLOCAL_ID) plasticityType call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp), & @@ -918,7 +918,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac call plastic_phenopowerlaw_dotState(Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_dotState(math_Mandel33to6(Mp),ipc,ip,el) + call plastic_kinehardening_dotState(Mp,ipc,ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType call plastic_dislotwin_dotState (math_Mandel33to6(Mp),temperature(ho)%p(tme), & @@ -1012,7 +1012,7 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_deltaState(math_Mandel33to6(Mstar),ipc,ip,el) + call plastic_kinehardening_deltaState(Mstar,ipc,ip,el) case (PLASTICITY_NONLOCAL_ID) plasticityType call plastic_nonlocal_deltaState(math_Mandel33to6(Mstar),ip,el) @@ -1141,7 +1141,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) plastic_phenopowerlaw_postResults(Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType constitutive_postResults(startPos:endPos) = & - plastic_kinehardening_postResults(S6,ipc,ip,el) + plastic_kinehardening_postResults(Mp,ipc,ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType constitutive_postResults(startPos:endPos) = & plastic_dislotwin_postResults(S6,temperature(ho)%p(tme),ipc,ip,el) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 2eb6ac4aa..858e71a84 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -534,17 +534,18 @@ end subroutine plastic_kinehardening_init !> @brief calculation of shear rates (\dot \gamma) !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Tstar_v,ph,instance,of) + Mp,ph,instance,of) + use math use lattice, only: & lattice_NslipSystem, & - lattice_Sslip_v, & + lattice_Sslip, & lattice_maxNslipFamily, & lattice_NnonSchmid implicit none - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt), intent(in) :: & ph, & !< phase ID instance, & !< instance of that phase @@ -565,13 +566,13 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) j = j + 1_pInt - tau_pos(j) = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_pos(j) = math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph)) tau_neg(j) = tau_pos(j) nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) tau_pos(j) = tau_pos(j) + param(instance)%nonSchmidCoeff(k)* & - dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+0,index_myFamily+i,ph)) + math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,2*k+0,index_myFamily+i,ph)) tau_neg(j) = tau_neg(j) + param(instance)%nonSchmidCoeff(k)* & - dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph)) enddo nonSchmidSystems enddo slipSystems enddo slipFamilies @@ -593,7 +594,7 @@ end subroutine plastic_kinehardening_shearRates !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & - Tstar_v,ipc,ip,el) + Mp,ipc,ip,el) use prec, only: & dNeq0 use debug, only: & @@ -627,8 +628,8 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & ipc, & !< component-ID of integration point ip, & !< integration point el !< element - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt) :: & instance, & @@ -653,7 +654,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & dLp_dMp = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Tstar_v,ph,instance,of) + Mp,ph,instance,of) j = 0_pInt ! reading and marking the starting index for each slip family @@ -701,7 +702,7 @@ end subroutine plastic_kinehardening_LpAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief calculates (instantaneous) incremental change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_deltaState(Tstar_v,ipc,ip,el) +subroutine plastic_kinehardening_deltaState(Mp,ipc,ip,el) use prec, only: & dNeq, & dEq0 @@ -719,8 +720,8 @@ subroutine plastic_kinehardening_deltaState(Tstar_v,ipc,ip,el) phase_plasticityInstance implicit none - real(pReal), dimension(6), intent(in):: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point @@ -740,7 +741,7 @@ subroutine plastic_kinehardening_deltaState(Tstar_v,ipc,ip,el) instance = phase_plasticityInstance(ph) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Tstar_v,ph,instance,of) + Mp,ph,instance,of) sense = merge(state(instance)%sense(:,of), & ! keep existing... sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction @@ -781,7 +782,7 @@ end subroutine plastic_kinehardening_deltaState !-------------------------------------------------------------------------------------------------- !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_dotState(Tstar_v,ipc,ip,el) +subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) use lattice, only: & lattice_maxNslipFamily use material, only: & @@ -790,8 +791,8 @@ subroutine plastic_kinehardening_dotState(Tstar_v,ipc,ip,el) phase_plasticityInstance implicit none - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation, vector form + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point @@ -815,7 +816,7 @@ subroutine plastic_kinehardening_dotState(Tstar_v,ipc,ip,el) dotState(instance)%sumGamma(of) = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Tstar_v,ph,instance,of) + Mp,ph,instance,of) j = 0_pInt slipFamilies: do f = 1_pInt,lattice_maxNslipFamily @@ -848,19 +849,20 @@ end subroutine plastic_kinehardening_dotState !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -function plastic_kinehardening_postResults(Tstar_v,ipc,ip,el) +function plastic_kinehardening_postResults(Mp,ipc,ip,el) + use math use material, only: & material_phase, & phaseAt, phasememberAt, & phase_plasticityInstance use lattice, only: & - lattice_Sslip_v, & + lattice_Sslip, & lattice_maxNslipFamily, & lattice_NslipSystem implicit none - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point @@ -889,7 +891,7 @@ function plastic_kinehardening_postResults(Tstar_v,ipc,ip,el) c = 0_pInt call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Tstar_v,ph,instance,of) + Mp,ph,instance,of) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(param(instance)%outputID(o)) @@ -932,7 +934,7 @@ function plastic_kinehardening_postResults(Tstar_v,ipc,ip,el) slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) j = j + 1_pInt plastic_kinehardening_postResults(c+j) = & - dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph)) enddo slipSystems enddo slipFamilies c = c + nSlip From c7fb868b40b9846a5057325837d4434b792ba197 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 23 Nov 2018 07:01:04 +0100 Subject: [PATCH 070/372] state layout was broken --- src/plastic_kinematichardening.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 858e71a84..30088ac4f 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -424,6 +424,7 @@ subroutine plastic_kinehardening_init(fileUnit) call material_allocatePlasticState(phase,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & nSlip,0_pInt,0_pInt) + plasticState(phase)%offsetDeltaState = sizeDotState plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt From 0e55bd61401c5bbe3b7e89d037c807375314caa1 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 23 Nov 2018 15:49:43 +0100 Subject: [PATCH 071/372] started read parallelization but getting errors --- src/HDF5_utilities.f90 | 71 +++++++++++++++++++++++++++++++++++++----- 1 file changed, 64 insertions(+), 7 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index cda585363..500be4278 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -374,7 +374,10 @@ end subroutine HDF5_read_pReal_4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of the type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) +subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset @@ -382,16 +385,70 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) + logical, intent(in), optional :: parallel + integer :: ierr + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + + integer(HDF5_ERR_TYPE) :: hdferr + integer(HSIZE_T), dimension(5) :: myStart + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + + myShape = shape(dataset) + + + localShape = shape(dataset) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(5) + +!>>>>>>>>>!New additions + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + write(6,*) plist_id +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal5: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:4),sum(readSize)] + +!>>>>>>>>>!New additions +!------------------------------------------------------------------------------------------------- +! Open the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr) if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) +!------------------------------------------------------------------------------------------------- +! get the dataspace_id of the dataset + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_5: h5dget_space_f') +!------------------------------------------------------------------------------------------------- +! select hyperslab (part to be read by the current process) + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart,int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_5: h5sselect_hyperslab_f') + write(6,*) filespace_id +!------------------------------------------------------------------------------------------------- +! read the part of the file + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') + +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') + !call h5sclose_f(filespace_id, hdferr) + !if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') + !call h5sclose_f(memspace_id, hdferr) + !if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal_5 From e7581f06d95a0062211a9dbd5789bd1fda3f7507 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 23 Nov 2018 17:54:02 +0100 Subject: [PATCH 072/372] Fixed error with parallel write --- src/HDF5_utilities.f90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index cda585363..57c505645 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -381,11 +381,18 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file integer(pInt),dimension(:), allocatable :: myShape + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id myShape = shape(dataset) + +!-------------------------------------------------------------------------------------------------- +!creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + + call h5dopen_f(loc_id,datasetName,dset_id,hdferr) if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) From c0ce95183c1927aa42c3b00a7782420e38a2aa2c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 25 Nov 2018 10:59:36 +0100 Subject: [PATCH 073/372] can be easily calculated during post processing and does not have to be a state --- src/plastic_kinematichardening.f90 | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 30088ac4f..0fc1d1464 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -40,7 +40,6 @@ module plastic_kinehardening chi0_ID, & !< backstress at last switch of stress sense (positive?) gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) accshear_ID, & - sumGamma_ID, & shearrate_ID, & resolvedstress_ID @@ -260,9 +259,6 @@ subroutine plastic_kinehardening_init(fileUnit) case ('accumulatedshear') output_ID = accshear_ID - case ('totalshear') - output_ID = sumGamma_ID - case ('shearrate') output_ID = shearrate_ID @@ -399,8 +395,6 @@ subroutine plastic_kinehardening_init(fileUnit) shearrate_ID, & resolvedstress_ID) mySize = nSlip - case(sumGamma_ID) - mySize = 1_pInt case default end select @@ -920,10 +914,6 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%accshear(:,of) c = c + nSlip - case (sumGamma_ID) - plastic_kinehardening_postResults(c+1_pInt) = state(instance)%sumGamma(of) - c = c + 1_pInt - case (shearrate_ID) plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = gdot_pos+gdot_neg c = c + nSlip From 917453d1918fcb3af6889703b5ed0cf31cd017b2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 25 Nov 2018 11:14:09 +0100 Subject: [PATCH 074/372] polishing --- src/plastic_kinematichardening.f90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 0fc1d1464..457ec3b48 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -1,9 +1,9 @@ !-------------------------------------------------------------------------------------------------- !> @author Philip Eisenlohr, Michigan State University !> @author Zhuowen Zhao, Michigan State University -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Introducing Voce-type kinematic hardening rule into crystal plasticity -!! formulation using a power law fitting +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Phenomenological crystal plasticity using a power law formulation for the shear rates +!! and a Voce-type kinematic hardening rule !-------------------------------------------------------------------------------------------------- module plastic_kinehardening use prec, only: & @@ -33,19 +33,19 @@ module plastic_kinehardening enum, bind(c) - enumerator :: undefined_ID, & - crss_ID, & !< critical resolved stress - crss_back_ID, & !< critical resolved back stress - sense_ID, & !< sense of acting shear stress (-1 or +1) - chi0_ID, & !< backstress at last switch of stress sense (positive?) - gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) - accshear_ID, & - shearrate_ID, & - resolvedstress_ID - + enumerator :: & + undefined_ID, & + crss_ID, & !< critical resolved stress + crss_back_ID, & !< critical resolved back stress + sense_ID, & !< sense of acting shear stress (-1 or +1) + chi0_ID, & !< backstress at last switch of stress sense (positive?) + gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) + accshear_ID, & + shearrate_ID, & + resolvedstress_ID end enum - - + + type, private :: tParameters !< container type for internal constitutive parameters integer(kind(undefined_ID)), dimension(:), allocatable, private :: & outputID !< ID of each post result output From 6f93f8de04ffe49a34c5f95fa6f7a504703042f2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 25 Nov 2018 19:37:46 +0100 Subject: [PATCH 075/372] starting to introduce parallel structure for new style parameter reading --- src/plastic_kinematichardening.f90 | 105 +++++++++++++++++++++++++++-- 1 file changed, 98 insertions(+), 7 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 457ec3b48..11f49202a 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -47,9 +47,6 @@ module plastic_kinehardening type, private :: tParameters !< container type for internal constitutive parameters - integer(kind(undefined_ID)), dimension(:), allocatable, private :: & - outputID !< ID of each post result output - real(pReal) :: & gdot0, & !< reference shear strain rate for slip (input parameter) n_slip, & !< stress exponent for slip (input parameter) @@ -67,9 +64,21 @@ module plastic_kinehardening tau1_b, & interaction_slipslip, & !< latent hardening matrix nonSchmidCoeff + + real(pReal), allocatable, dimension(:,:,:) :: & + Schmid_slip, & + Schmid_twin, & + nonSchmid_pos, & + nonSchmid_neg real(pReal), dimension(:,:), allocatable, private :: & hardeningMatrix_SlipSlip + integer(pInt) :: & + totalNslip !< total number of active slip system + integer(pInt), allocatable, dimension(:) :: & + Nslip !< number of active slip systems for each family + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID !< ID of each post result output end type type, private :: tKinehardeningState @@ -86,8 +95,9 @@ module plastic_kinehardening end type type(tParameters), dimension(:), allocatable, private :: & - param !< containers of constitutive parameters (len Ninstance) - + param, & !< containers of constitutive parameters (len Ninstance) + paramNew ! temp + type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & deltaState, & @@ -148,6 +158,7 @@ subroutine plastic_kinehardening_init(fileUnit) material_phase, & plasticState use config, only: & + config_phase, & MATERIAL_partPhase use lattice @@ -158,11 +169,12 @@ subroutine plastic_kinehardening_init(fileUnit) integer(kind(undefined_ID)) :: & output_ID integer(pInt) :: & - o, j, k, f, & + o, i,j, k, f, p, & phase, & instance, & maxNinstance, & NipcMyPhase, & + outputSize, & Nchunks_SlipSlip = 0_pInt, Nchunks_SlipFamilies = 0_pInt, & Nchunks_nonSchmid = 0_pInt, & offset_slip, index_myFamily, index_otherFamily, & @@ -172,12 +184,21 @@ subroutine plastic_kinehardening_init(fileUnit) sizeState, & sizeDeltaState + integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] + real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + real(pReal), dimension(:), allocatable :: tempPerSlip + integer(kind(undefined_ID)) :: & + outputID !< ID of each post result output + character(len=65536), dimension(:), allocatable :: & + outputs character(len=65536) :: & tag = '', & line = '', & - extmsg = '' + extmsg = '', & + structure = '' write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_KINEHARDENING_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -198,7 +219,77 @@ subroutine plastic_kinehardening_init(fileUnit) allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) allocate(plastic_kinehardening_totalNslip(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance + allocate(paramNew(maxNinstance)) ! one container of parameters per instance + + do p = 1_pInt, size(phase_plasticityInstance) + if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle + associate(prm => paramNew(phase_plasticityInstance(p)), & + dot => dotState(phase_plasticityInstance(p)), & + stt => state(phase_plasticityInstance(p))) + + structure = config_phase(p)%getString('lattice_structure') + +!-------------------------------------------------------------------------------------------------- +! optional parameters that need to be defined + prm%aTolResistance = config_phase(p)%getFloat('atol_resistance',defaultVal=1.0_pReal) + prm%aTolShear = config_phase(p)%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + +!-------------------------------------------------------------------------------------------------- +! slip related parameters + prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) + prm%totalNslip = sum(prm%Nslip) + slipActive: if (prm%totalNslip > 0_pInt) then + prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& + config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + if(structure=='bcc') then + prm%nonSchmidCoeff = config_phase(p)%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) + else + prm%nonSchmid_pos = prm%Schmid_slip + prm%nonSchmid_neg = prm%Schmid_slip + endif + !prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & + ! config_phase(p)%getFloats('interaction_slipslip'), & + ! structure(1:3)) + endif slipActive + +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config_phase(p)%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + case ('resistance') + outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('accumulatedshear') + outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('shearrate') + outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('resolvedstress') + outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + + end select + + if (outputID /= undefined_ID) then + plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize + prm%outputID = [prm%outputID , outputID] + endif + + end do + + end associate + end do + + rewind(fileUnit) phase = 0_pInt do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to From 9f81fa8e9a902af78de75e8638f9322cb4075f29 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 25 Nov 2018 21:39:59 +0100 Subject: [PATCH 076/372] prevent segmentation fault post_results better readable --- src/plastic_kinematichardening.f90 | 33 +++++++++++++++--------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 11f49202a..bd97c7de3 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -219,7 +219,11 @@ subroutine plastic_kinehardening_init(fileUnit) allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) allocate(plastic_kinehardening_totalNslip(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance - allocate(paramNew(maxNinstance)) ! one container of parameters per instance + allocate(paramNew(maxNinstance)) + allocate(state(maxNinstance)) + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + allocate(deltaState(maxNinstance)) do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle @@ -435,10 +439,7 @@ subroutine plastic_kinehardening_init(fileUnit) !-------------------------------------------------------------------------------------------------- ! allocation of variables whose size depends on the total number of active slip systems - allocate(state(maxNinstance)) - allocate(state0(maxNinstance)) - allocate(dotState(maxNinstance)) - allocate(deltaState(maxNinstance)) + initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config @@ -935,7 +936,7 @@ end subroutine plastic_kinehardening_dotState !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -function plastic_kinehardening_postResults(Mp,ipc,ip,el) +function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) use math use material, only: & material_phase, & @@ -955,7 +956,7 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) el !< element !< microstructure state real(pReal), dimension(plastic_kinehardening_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & - plastic_kinehardening_postResults + postResults integer(pInt) :: & instance,ph, of, & @@ -973,7 +974,7 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) nSlip = plastic_kinehardening_totalNslip(instance) - plastic_kinehardening_postResults = 0.0_pReal + postResults = 0.0_pReal c = 0_pInt call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & @@ -982,31 +983,31 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(param(instance)%outputID(o)) case (crss_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%crss(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%crss(:,of) c = c + nSlip case(crss_back_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%crss_back(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%crss_back(:,of) c = c + nSlip case (sense_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%sense(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%sense(:,of) c = c + nSlip case (chi0_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%chi0(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%chi0(:,of) c = c + nSlip case (gamma0_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%gamma0(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%gamma0(:,of) c = c + nSlip case (accshear_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%accshear(:,of) + postResults(c+1_pInt:c+nSlip) = state(instance)%accshear(:,of) c = c + nSlip case (shearrate_ID) - plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = gdot_pos+gdot_neg + postResults(c+1_pInt:c+nSlip) = gdot_pos+gdot_neg c = c + nSlip case (resolvedstress_ID) @@ -1015,7 +1016,7 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) j = j + 1_pInt - plastic_kinehardening_postResults(c+j) = & + postResults(c+j) = & math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph)) enddo slipSystems enddo slipFamilies From 4c46f3daa591df7603bf6d0acdb6b9bfd47a1067 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 26 Nov 2018 00:14:27 +0100 Subject: [PATCH 077/372] adopting argument parsing to Phenopowerlaw --- src/plastic_kinematichardening.f90 | 184 +++++++++++++++-------------- 1 file changed, 93 insertions(+), 91 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index bd97c7de3..6fb469b92 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -229,6 +229,7 @@ subroutine plastic_kinehardening_init(fileUnit) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle associate(prm => paramNew(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & + delta => deltaState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p))) structure = config_phase(p)%getString('lattice_structure') @@ -238,6 +239,10 @@ subroutine plastic_kinehardening_init(fileUnit) prm%aTolResistance = config_phase(p)%getFloat('atol_resistance',defaultVal=1.0_pReal) prm%aTolShear = config_phase(p)%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + ! sanity checks + if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//'aTolresistance ' + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//'aTolShear ' + !-------------------------------------------------------------------------------------------------- ! slip related parameters prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) @@ -254,6 +259,16 @@ subroutine plastic_kinehardening_init(fileUnit) prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip endif + + prm%crss0 = config_phase(p)%getFloats('crss0', requiredShape=shape(prm%Nslip)) + prm%tau1 = config_phase(p)%getFloats('tau1', requiredShape=shape(prm%Nslip)) + prm%tau1_b = config_phase(p)%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) + prm%theta0 = config_phase(p)%getFloats('theta0', requiredShape=shape(prm%Nslip)) + prm%theta1 = config_phase(p)%getFloats('theta1', requiredShape=shape(prm%Nslip)) + prm%theta0_b = config_phase(p)%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) + prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + + !prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & ! config_phase(p)%getFloats('interaction_slipslip'), & ! structure(1:3)) @@ -282,13 +297,85 @@ subroutine plastic_kinehardening_init(fileUnit) end select - if (outputID /= undefined_ID) then - plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize - prm%outputID = [prm%outputID , outputID] - endif + !if (outputID /= undefined_ID) then + ! plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) + ! plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize + ! prm%outputID = [prm%outputID , outputID] + !endif end do + nslip = prm%totalNslip +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeDotState = nSlip & !< crss + + nSlip & !< crss_back + + nSlip & !< accumulated (absolute) shear + + 1_pInt !< sum(gamma) + + sizeDeltaState = nSlip & !< sense of acting shear stress (-1 or +1) + + nSlip & !< backstress at last switch of stress sense + + nSlip !< accumulated shear at last switch of stress sense + + sizeState = sizeDotState + sizeDeltaState + NipcMyPhase = count(material_phase == p) ! number of IPCs containing my phase + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & + nSlip,0_pInt,0_pInt) + plasticState(p)%offsetDeltaState = sizeDotState + + + endindex = 0_pInt + o = endIndex ! offset of dotstate index relative to state index + + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%crss => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + dot%crss => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolResistance + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%crss_back => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + dot%crss_back => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolResistance + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%accshear => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + dot%accshear => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolShear + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + 1_pInt + stt%sumGamma => plasticState(p)%state (startIndex ,1:NipcMyPhase) + dot%sumGamma => plasticState(p)%dotState (startIndex-o ,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex-o:endIndex-o) =prm%aTolShear + +!---------------------------------------------------------------------------------------------- +!locally define deltaState alias + o = endIndex + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%sense => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%chi0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) + delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + end associate end do @@ -464,9 +551,7 @@ subroutine plastic_kinehardening_init(fileUnit) if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' - if (param(instance)%aTolResistance <= 0.0_pReal) param(instance)%aTolResistance = 1.0_pReal ! default absolute tolerance 1 Pa - if (param(instance)%aTolShear <= 0.0_pReal) param(instance)%aTolShear = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (extmsg /= '') then extmsg = trim(extmsg)//' ('//PLASTICITY_KINEHARDENING_label//')' ! prepare error message identifier call IO_error(211_pInt,ip=instance,ext_msg=extmsg) @@ -495,22 +580,7 @@ subroutine plastic_kinehardening_init(fileUnit) plastic_kinehardening_sizePostResults(instance) = plastic_kinehardening_sizePostResults(instance) + mySize endif outputFound enddo outputsLoop -!-------------------------------------------------------------------------------------------------- -! allocate state arrays - sizeDotState = nSlip & !< crss - + nSlip & !< crss_back - + nSlip & !< accumulated (absolute) shear - + 1_pInt !< sum(gamma) - - sizeDeltaState = nSlip & !< sense of acting shear stress (-1 or +1) - + nSlip & !< backstress at last switch of stress sense - + nSlip !< accumulated shear at last switch of stress sense - sizeState = sizeDotState + sizeDeltaState - - call material_allocatePlasticState(phase,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & - nSlip,0_pInt,0_pInt) - plasticState(phase)%offsetDeltaState = sizeDotState plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt @@ -534,84 +604,16 @@ subroutine plastic_kinehardening_init(fileUnit) enddo; enddo enddo; enddo -!---------------------------------------------------------------------------------------------- -!locally define dotState alias - endindex = 0_pInt o = endIndex ! offset of dotstate index relative to state index startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip - state (instance)%crss => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) state0 (instance)%crss => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - dotState(instance)%crss => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) state0(instance)%crss = spread(math_expand(param(instance)%crss0,& plastic_kinehardening_Nslip(:,instance)), & 2, NipcMyPhase) - plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolResistance - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - state (instance)%crss_back => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) - state0 (instance)%crss_back => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - dotState(instance)%crss_back => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) - - state0(instance)%crss_back = 0.0_pReal - plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolResistance - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - state (instance)%accshear => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) - state0 (instance)%accshear => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - dotState(instance)%accshear => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) - - state0(instance)%accshear = 0.0_pReal - plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolShear - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + 1_pInt - state (instance)%sumGamma => plasticState(phase)%state (startIndex ,1:NipcMyPhase) - state0 (instance)%sumGamma => plasticState(phase)%state0 (startIndex ,1:NipcMyPhase) - dotState(instance)%sumGamma => plasticState(phase)%dotState (startIndex-o ,1:NipcMyPhase) - - state0(instance)%sumGamma = 0.0_pReal - plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolShear - -!---------------------------------------------------------------------------------------------- -!locally define deltaState alias - o = endIndex - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - state (instance)%sense => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) - state0 (instance)%sense => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - deltaState(instance)%sense => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - state0(instance)%sense = 0.0_pReal - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - state (instance)%chi0 => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) - state0 (instance)%chi0 => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - deltaState(instance)%chi0 => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - state0(instance)%chi0 = 0.0_pReal - -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - state (instance)%gamma0 => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) - state0 (instance)%gamma0 => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - deltaState(instance)%gamma0 => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - state0(instance)%gamma0 = 0.0_pReal - endif myPhase2 enddo initializeInstances From 8f59a40f482ef1a0e6d32c6007d951e77c751172 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 26 Nov 2018 01:34:38 +0100 Subject: [PATCH 078/372] using new parameter structure for output --- src/plastic_kinematichardening.f90 | 102 +++++++---------------------- 1 file changed, 23 insertions(+), 79 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 6fb469b92..5db5a3b5a 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -12,9 +12,6 @@ module plastic_kinehardening implicit none private - integer(pInt), dimension(:), allocatable, public, protected :: & - plastic_kinehardening_sizePostResults !< cumulative size of post results - integer(pInt), dimension(:,:), allocatable, target, public :: & plastic_kinehardening_sizePostResult !< size of each post result output @@ -210,7 +207,6 @@ subroutine plastic_kinehardening_init(fileUnit) if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a,1x,i5,/)') '# instances:',maxNinstance - allocate(plastic_kinehardening_sizePostResults(maxNinstance), source=0_pInt) allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),maxNinstance), & source=0_pInt) allocate(plastic_kinehardening_output(maxval(phase_Noutput),maxNinstance)) @@ -224,9 +220,9 @@ subroutine plastic_kinehardening_init(fileUnit) allocate(state0(maxNinstance)) allocate(dotState(maxNinstance)) allocate(deltaState(maxNinstance)) - do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle + instance = phase_plasticityInstance(p) ! which instance of my phase associate(prm => paramNew(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & delta => deltaState(phase_plasticityInstance(p)), & @@ -294,16 +290,30 @@ subroutine plastic_kinehardening_init(fileUnit) case ('resolvedstress') outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) outputSize = prm%totalNslip + case ('backstress') + outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('sense') + outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('chi0') + outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('gamma0') + outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip end select - !if (outputID /= undefined_ID) then - ! plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) - ! plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize - ! prm%outputID = [prm%outputID , outputID] - !endif + if (outputID /= undefined_ID) then + plastic_kinehardening_Noutput(instance) = plastic_kinehardening_Noutput(instance) + 1_pInt + plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize + prm%outputID = [prm%outputID , outputID] + endif end do +param(instance)%outputID = prm%outputID nslip = prm%totalNslip !-------------------------------------------------------------------------------------------------- ! allocate state arrays @@ -320,6 +330,7 @@ subroutine plastic_kinehardening_init(fileUnit) NipcMyPhase = count(material_phase == p) ! number of IPCs containing my phase call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & nSlip,0_pInt,0_pInt) + plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) plasticState(p)%offsetDeltaState = sizeDotState @@ -412,7 +423,6 @@ subroutine plastic_kinehardening_init(fileUnit) allocate(param(instance)%nonSchmidCoeff(Nchunks_nonSchmid), source=0.0_pReal) if(allocated(tempPerSlip)) deallocate(tempPerSlip) allocate(tempPerSlip(Nchunks_SlipFamilies)) - allocate(param(instance)%outputID(0)) endif cycle ! skip to next line endif @@ -420,41 +430,7 @@ subroutine plastic_kinehardening_init(fileUnit) chunkPos = IO_stringPos(line) tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key select case(tag) - case ('(output)') - output_ID = undefined_ID - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('resistance') - output_ID = crss_ID - case ('backstress') - output_ID = crss_back_ID - - case ('sense') - output_ID = sense_ID - - case ('chi0') - output_ID = chi0_ID - - case ('gamma0') - output_ID = gamma0_ID - - case ('accumulatedshear') - output_ID = accshear_ID - - case ('shearrate') - output_ID = shearrate_ID - - case ('resolvedstress') - output_ID = resolvedstress_ID - - end select - - if (output_ID /= undefined_ID) then - plastic_kinehardening_Noutput(instance) = plastic_kinehardening_Noutput(instance) + 1_pInt - plastic_kinehardening_output(plastic_kinehardening_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - param(instance)%outputID = [param(instance)%outputID, output_ID] - endif !-------------------------------------------------------------------------------------------------- ! parameters depending on number of slip families @@ -511,12 +487,6 @@ subroutine plastic_kinehardening_init(fileUnit) case ('n_slip') param(instance)%n_slip = IO_floatValue(line,chunkPos,2_pInt) - - case ('atol_resistance') - param(instance)%aTolResistance = IO_floatValue(line,chunkPos,2_pInt) - - case ('atol_shear') - param(instance)%aTolShear = IO_floatValue(line,chunkPos,2_pInt) case default @@ -556,32 +526,7 @@ subroutine plastic_kinehardening_init(fileUnit) extmsg = trim(extmsg)//' ('//PLASTICITY_KINEHARDENING_label//')' ! prepare error message identifier call IO_error(211_pInt,ip=instance,ext_msg=extmsg) endif - - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - - outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) - select case(param(instance)%outputID(o)) - case(crss_ID, & !< critical resolved stress - crss_back_ID, & !< critical resolved back stress - sense_ID, & !< sense of acting shear stress (-1 or +1) - chi0_ID, & !< backstress at last switch of stress sense - gamma0_ID, & !< accumulated shear at last switch of stress sense - accshear_ID, & - shearrate_ID, & - resolvedstress_ID) - mySize = nSlip - case default - end select - - outputFound: if (mySize > 0_pInt) then - plastic_kinehardening_sizePostResult(o,instance) = mySize - plastic_kinehardening_sizePostResults(instance) = plastic_kinehardening_sizePostResults(instance) + mySize - endif outputFound - enddo outputsLoop - - plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) + offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt plasticState(phase)%slipRate => & @@ -957,9 +902,8 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) ip, & !< integration point el !< element !< microstructure state - real(pReal), dimension(plastic_kinehardening_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(material_phase(ipc,ip,el))))) :: & postResults - integer(pInt) :: & instance,ph, of, & nSlip,& From c63d297145fd5efa7ffa06f9413d02d84f6a1e8d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 26 Nov 2018 07:10:43 +0100 Subject: [PATCH 079/372] copied from phenopowerlaw --- src/plastic_kinematichardening.f90 | 79 ++++++++++++++++++++++++++++++ 1 file changed, 79 insertions(+) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 5db5a3b5a..777e7e16b 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -265,6 +265,11 @@ subroutine plastic_kinehardening_init(fileUnit) prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + prm%gdot0 = config_phase(p)%getFloat('gdot0') + prm%n_slip = config_phase(p)%getFloat('n_slip') + + + !prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & ! config_phase(p)%getFloats('interaction_slipslip'), & ! structure(1:3)) @@ -973,4 +978,78 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) end function plastic_kinehardening_postResults + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates shear rates on slip systems and derivatives with respect to resolved stress +!> @details: Shear rates are calculated only optionally. NOTE: Against the common convention, the +!> result (i.e. intent(out)) variables are the last to have the optional arguments at the end +!-------------------------------------------------------------------------------------------------- +pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg, & + dgdot_dtau_pos,dgdot_dtau_neg) + use prec, only: & + dNeq0 + use math, only: & + math_mul33xx33 + + implicit none + type(tParameters), intent(in) :: & + prm + type(tKinehardeningState), intent(in) :: & + stt + integer(pInt), intent(in) :: & + of + real(pReal), dimension(prm%totalNslip), intent(out) :: & + gdot_pos, & + gdot_neg + real(pReal), dimension(prm%totalNslip), optional, intent(out) :: & + dgdot_dtau_pos, & + dgdot_dtau_neg + real(pReal), dimension(3,3), intent(in) :: & + Mp + + real(pReal), dimension(prm%totalNslip) :: & + tau_pos, & + tau_neg + integer(pInt) :: i + logical :: nonSchmidActive + + nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt + + do i = 1_pInt, prm%totalNslip + tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) + tau_neg(i) = merge(math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)), & + 0.0_pReal, nonSchmidActive) + enddo + + where(dNeq0(tau_pos)) + gdot_pos = prm%gdot0 * merge(0.5_pReal,1.0_pReal, nonSchmidActive) & ! 1/2 if non-Schmid active + * sign(abs((tau_pos-stt%crss_back(:,of))/stt%crss(:,of))**prm%n_slip, tau_pos-stt%crss_back(:,of)) + else where + gdot_pos = 0.0_pReal + end where + + where(dNeq0(tau_neg)) + gdot_pos = prm%gdot0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 + * sign(abs((tau_pos-stt%crss_back(:,of))/stt%crss(:,of))**prm%n_slip, tau_pos-stt%crss_back(:,of)) + else where + gdot_neg = 0.0_pReal + end where + + if (present(dgdot_dtau_pos)) then + where(dNeq0(gdot_pos)) + !dgdot_dtau_slip_pos = gdot_slip_pos*prm%n_slip/tau_slip_pos + else where + dgdot_dtau_pos = 0.0_pReal + end where + endif + if (present(dgdot_dtau_neg)) then + where(dNeq0(gdot_neg)) + ! dgdot_dtau_slip_neg = gdot_slip_neg*prm%n_slip/tau_slip_neg + else where + dgdot_dtau_neg = 0.0_pReal + end where + endif + +end subroutine kinetics + end module plastic_kinehardening From ef1e9cce0df29fc0b080466ca960f58eba991b33 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Mon, 26 Nov 2018 15:38:31 +0100 Subject: [PATCH 080/372] Functionality to avoid creating datasets in HDF5 of zero dimensions --- src/HDF5_utilities.f90 | 220 ++++++++++++++++++++++++++++------------- 1 file changed, 151 insertions(+), 69 deletions(-) mode change 100644 => 100755 src/HDF5_utilities.f90 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100644 new mode 100755 index 57c505645..3d882da7b --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -374,7 +374,10 @@ end subroutine HDF5_read_pReal_4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of the type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) +subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset @@ -383,8 +386,16 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) integer(pInt),dimension(:), allocatable :: myShape integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + logical, intent(in), optional :: parallel + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer(HSIZE_T), dimension(5) :: myStart + myShape = shape(dataset) @@ -392,13 +403,44 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName) !creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - +!-------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(5) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal5: MPI_allreduce') + endif; endif +#endif + myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:4),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr) if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) +!-------------------------------------------------------------------------------------------------- +!get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dget_space_f') +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5sselect_hyperslab_f') +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T),hdferr) if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dclose_f') +!-------------------------------------------------------------------------------------------------- +! close property lists and datatypes + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') end subroutine HDF5_read_pReal_5 @@ -618,7 +660,6 @@ subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) end subroutine HDF5_read_pInt_7 - !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- @@ -638,26 +679,29 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(1) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(1) -#ifdef PETSc + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') endif; endif -#endif + #endif myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(outputSize)] @@ -693,15 +737,15 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5sclose_f/memspace_id') -end subroutine HDF5_write_pReal1 +end subroutine HDF5_write_PReal1 !-------------------------------------------------------------------------------------------------- @@ -723,16 +767,19 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(2) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(2) #ifdef PETSc @@ -740,7 +787,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt2: MPI_allreduce') endif; endif #endif myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -808,16 +855,19 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(3) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(3) #ifdef PETSc @@ -825,7 +875,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt3: MPI_allreduce') endif; endif #endif myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -893,16 +943,19 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(4) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(4) #ifdef PETSc @@ -910,7 +963,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt4: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -978,16 +1031,19 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(5) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(5) #ifdef PETSc @@ -995,7 +1051,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt5: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1063,16 +1119,19 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(6) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(6) #ifdef PETSc @@ -1080,7 +1139,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt6: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1148,16 +1207,19 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) outputSize !< contribution of all processes + integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer :: ierr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(7) :: myStart +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(7) #ifdef PETSc @@ -1165,7 +1227,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt7: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1214,8 +1276,10 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) end subroutine HDF5_write_pReal7 + + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of the type pInt with 1 dimensions +!> @brief subroutine for writing dataset of type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) use numerics, only: & @@ -1238,12 +1302,14 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(1) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(1) #ifdef PETSc @@ -1324,12 +1390,14 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(2) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(2) #ifdef PETSc @@ -1410,12 +1478,14 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(3) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(3) #ifdef PETSc @@ -1496,12 +1566,14 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(4) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(4) #ifdef PETSc @@ -1582,12 +1654,14 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(5) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(5) #ifdef PETSc @@ -1668,12 +1742,14 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(6) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(6) #ifdef PETSc @@ -1754,12 +1830,14 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(7) :: myStart - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(7) #ifdef PETSc @@ -1820,3 +1898,7 @@ end module HDF5_Utilities + + + + From bfad81848ae044312c2a6cf2cf3c2f98e15a2346 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 26 Nov 2018 22:36:32 +0100 Subject: [PATCH 081/372] kinetics similar to phenopowerlaw --- src/plastic_kinematichardening.f90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 777e7e16b..590267890 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -1021,30 +1021,33 @@ pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg, & 0.0_pReal, nonSchmidActive) enddo + tau_pos = tau_pos - stt%crss_back(:,of) + tau_neg = tau_neg - stt%crss_back(:,of) + where(dNeq0(tau_pos)) - gdot_pos = prm%gdot0 * merge(0.5_pReal,1.0_pReal, nonSchmidActive) & ! 1/2 if non-Schmid active - * sign(abs((tau_pos-stt%crss_back(:,of))/stt%crss(:,of))**prm%n_slip, tau_pos-stt%crss_back(:,of)) + gdot_pos = prm%gdot0 * merge(0.5_pReal,1.0_pReal, nonSchmidActive) & ! 1/2 if non-Schmid active + * sign(abs(tau_pos/stt%crss(:,of))**prm%n_slip, tau_pos) else where gdot_pos = 0.0_pReal end where where(dNeq0(tau_neg)) - gdot_pos = prm%gdot0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 - * sign(abs((tau_pos-stt%crss_back(:,of))/stt%crss(:,of))**prm%n_slip, tau_pos-stt%crss_back(:,of)) + gdot_neg = prm%gdot0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 + * sign(abs(tau_neg/stt%crss(:,of))**prm%n_slip, tau_neg) else where gdot_neg = 0.0_pReal end where if (present(dgdot_dtau_pos)) then where(dNeq0(gdot_pos)) - !dgdot_dtau_slip_pos = gdot_slip_pos*prm%n_slip/tau_slip_pos + dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos else where dgdot_dtau_pos = 0.0_pReal end where endif if (present(dgdot_dtau_neg)) then where(dNeq0(gdot_neg)) - ! dgdot_dtau_slip_neg = gdot_slip_neg*prm%n_slip/tau_slip_neg + dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg else where dgdot_dtau_neg = 0.0_pReal end where From 0265732e084f8e3c9cdcd286fb1b06a5fc0d99d6 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Tue, 27 Nov 2018 18:50:51 +0100 Subject: [PATCH 082/372] Parallel writing and reading of integer datasets working --- src/HDF5_utilities.f90 | 1401 ++++++++++++++++++++++++++++++++-------- 1 file changed, 1130 insertions(+), 271 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 3d882da7b..01ca3407d 100755 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -5,11 +5,11 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module HDF5_utilities - use prec - use IO - use HDF5 + use prec + use IO + use HDF5 #ifdef PETSc - use PETSC + use PETSC #endif implicit none @@ -21,21 +21,21 @@ module HDF5_utilities !> @brief reads pInt or pReal data of defined shape from file !-------------------------------------------------------------------------------------------------- interface HDF5_read - module procedure HDF5_read_pReal_1 - module procedure HDF5_read_pReal_2 - module procedure HDF5_read_pReal_3 - module procedure HDF5_read_pReal_4 - module procedure HDF5_read_pReal_5 - module procedure HDF5_read_pReal_6 - module procedure HDF5_read_pReal_7 + module procedure HDF5_read_pReal1 + module procedure HDF5_read_pReal2 + module procedure HDF5_read_pReal3 + module procedure HDF5_read_pReal4 + module procedure HDF5_read_pReal5 + module procedure HDF5_read_pReal6 + module procedure HDF5_read_pReal7 - module procedure HDF5_read_pInt_1 - module procedure HDF5_read_pInt_2 - module procedure HDF5_read_pInt_3 - module procedure HDF5_read_pInt_4 - module procedure HDF5_read_pInt_5 - module procedure HDF5_read_pInt_6 - module procedure HDF5_read_pInt_7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK + module procedure HDF5_read_pInt1 + module procedure HDF5_read_pInt2 + module procedure HDF5_read_pInt3 + module procedure HDF5_read_pInt4 + module procedure HDF5_read_pInt5 + module procedure HDF5_read_pInt6 + module procedure HDF5_read_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK end interface HDF5_read @@ -277,135 +277,392 @@ subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) end subroutine HDF5_addIntegerAttribute -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 1 dimension -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_1(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape1: h5dclose_f') - -end subroutine HDF5_read_pReal_1 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 2 dimensions +!> @brief subroutine for reading dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_2(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape2: h5dclose_f') - -end subroutine HDF5_read_pReal_2 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 3 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_3(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape3: h5dclose_f') - -end subroutine HDF5_read_pReal_3 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 4 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_4(dataset,loc_id,datasetName) - - implicit none - real(pReal), intent(out), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape4: h5dclose_f') - -end subroutine HDF5_read_pReal_4 - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 5 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) use numerics, only: & worldrank, & worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id logical, intent(in), optional :: parallel - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr + integer(pInt), dimension(:), allocatable :: & globalShape, & !< shape of the dataset (all processes) localShape, & !< shape of the dataset (this process) readSize !< contribution of all processes - integer(HSIZE_T), dimension(5) :: myStart - - myShape = shape(dataset) + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(1) :: myStart - -!-------------------------------------------------------------------------------------------------- -!creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(1) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') + endif; endif +#endif + myStart = int([sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:0),sum(readSize)] + + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal2(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(2) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(2) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal2: MPI_allreduce') + endif; endif +#endif + myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:1),sum(readSize)] + + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal2 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + real(pReal), intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(3) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(3) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal3: MPI_allreduce') + endif; endif +#endif + myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:2),sum(readSize)] + + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal3 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(4) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(4) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal4: MPI_allreduce') + endif; endif +#endif + myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:3),sum(readSize)] + + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal4 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(5) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- allocate(readSize(worldsize), source = 0_pInt) readSize(worldrank+1) = localShape(5) #ifdef PETSc @@ -419,246 +676,845 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') ! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dopen_f') + !-------------------------------------------------------------------------------------------------- -!get the space_id of dataset in the file +! get the space_id of dataset in the file call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dget_space_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dget_space_f') + !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5sselect_hyperslab_f') + !-------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') + !-------------------------------------------------------------------------------------------------- -! close property lists and datatypes +!close types, dataspaces call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: plist_id') call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal5 -end subroutine HDF5_read_pReal_5 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 6 dimensions +!> @brief subroutine for reading dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_6(dataset,loc_id,datasetName) +subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape6: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(6) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(6) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal6: MPI_allreduce') + endif; endif +#endif + myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:5),sum(readSize)] -end subroutine HDF5_read_pReal_6 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pReal with 7 dimensions +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dopen_f') + !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal_7(dataset,loc_id,datasetName) +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape7: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(7) :: myStart + +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(7) +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal7: MPI_allreduce') + endif; endif +#endif + myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:6),sum(readSize)] -end subroutine HDF5_read_pReal_7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 1 dimension +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dopen_f') + !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_1(dataset,loc_id,datasetName) +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pReal7 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 1 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:) :: dataset + integer(pInt), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape1: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(1) :: myStart -end subroutine HDF5_read_pInt_1 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 2 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_2(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(1) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') + endif; endif +#endif + + myStart = int([sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:0),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + mem_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape2: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(2) :: myStart -end subroutine HDF5_read_pInt_2 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 3 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_3(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(2) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:1),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + mem_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt2 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 3 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape3: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(3) :: myStart -end subroutine HDF5_read_pInt_3 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 4 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_4(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(3) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:2),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt3 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 4 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape4: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(4) :: myStart -end subroutine HDF5_read_pInt_4 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 5 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_5(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(4) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:3),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt4 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 5 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape5: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(5) :: myStart -end subroutine HDF5_read_pInt_5 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 6 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_6(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(5) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:4),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt5 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 6 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape6: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(6) :: myStart -end subroutine HDF5_read_pInt_6 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of the type pInt with 7 dimensions +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt_7(dataset,loc_id,datasetName) + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(6) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:5),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pInt with 7 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize implicit none - integer(pInt), intent(out), dimension(:,:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - integer(pInt),dimension(:), allocatable :: myShape + logical, intent(in), optional :: parallel - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id - myShape = shape(dataset) - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dopen_f') - call h5dread_f(dset_id,H5T_NATIVE_INTEGER,dataset,int(myShape,HSIZE_T),hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dread_f') - call h5dclose_f(dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pInt__shape7: h5dclose_f') + integer(pInt), dimension(:), allocatable :: & + globalShape, & !< shape of the dataset (all processes) + localShape, & !< shape of the dataset (this process) + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(7) :: myStart -end subroutine HDF5_read_pInt_7 +!------------------------------------------------------------------------------------------------- +! determine shape of dataset + localShape = shape(dataset) + if (any(localShape(1:size(localShape)) == 0)) return + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + allocate(readSize(worldsize), source = 0_pInt) + readSize(worldrank+1) = localShape(7) + +#ifdef PETSc + if (present(parallel)) then; if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') + endif; endif +#endif + + myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) + globalShape = [localShape(1:6),sum(readSize)] + +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sselect_hyperslab_f') + +!-------------------------------------------------------------------------------------------------- +! read + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + file_space_id = filespace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + +end subroutine HDF5_read_pInt7 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 1 dimensions @@ -667,7 +1523,7 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) use numerics, only: & worldrank, & worldsize - + implicit none real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle @@ -694,14 +1550,14 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(1) - #ifdef PETSc +#ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') endif; endif - #endif +#endif myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(outputSize)] @@ -787,7 +1643,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt2: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') endif; endif #endif myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -875,7 +1731,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt3: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') endif; endif #endif myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -963,7 +1819,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt4: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1051,7 +1907,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt5: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1139,7 +1995,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt6: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1227,7 +2083,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt7: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -1896,6 +2752,9 @@ end subroutine HDF5_write_pInt7 end module HDF5_Utilities +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + From d33df38b429ebf2749a2a6c381881cdd2ce994b8 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Tue, 27 Nov 2018 18:52:54 +0100 Subject: [PATCH 083/372] made it non-executable --- src/HDF5_utilities.f90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 src/HDF5_utilities.f90 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100755 new mode 100644 From ab59274c357c40be21ebba6c9572df37f16dce78 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 30 Nov 2018 10:16:04 +0100 Subject: [PATCH 084/372] Able to read the independent datasets (outside the groups) in parallel --- src/HDF5_utilities.f90 | 144 ++++++++++++++++++++++++++++++++--------- 1 file changed, 115 insertions(+), 29 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 01ca3407d..60d4c705d 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -193,7 +193,19 @@ integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: FileReadID - call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr) + integer(HID_T) :: aplist_id + + !------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pcreate_f ('//trim(groupName)//')') + !------------------------------------------------------------------------------------------------- +! setting I/O mode to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + !------------------------------------------------------------------------------------------------- +! opening the group + call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr, gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5gopen_f ('//trim(groupName)//')') end function HDF5_openGroup2 @@ -321,14 +333,18 @@ subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif myStart = int([sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -408,14 +424,18 @@ subroutine HDF5_read_pReal2(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal2: MPI_allreduce') endif; endif #endif myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:1),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -495,14 +515,18 @@ subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal3: MPI_allreduce') endif; endif #endif myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:2),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -582,14 +606,19 @@ subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal4: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:3),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -669,13 +698,19 @@ subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal5: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(readSize)] + + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective @@ -698,7 +733,7 @@ subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id,mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -756,14 +791,18 @@ subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal6: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:5),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -843,14 +882,19 @@ subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal7: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:6),sum(readSize)] - + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -931,7 +975,7 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') endif; endif #endif @@ -939,10 +983,16 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) myStart = int([sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1021,7 +1071,7 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') endif; endif #endif @@ -1029,10 +1079,16 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:1),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1111,7 +1167,7 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') endif; endif #endif @@ -1119,10 +1175,16 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:2),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1201,7 +1263,7 @@ subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') endif; endif #endif @@ -1209,10 +1271,16 @@ subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:3),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1291,7 +1359,7 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') endif; endif #endif @@ -1299,10 +1367,16 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1381,7 +1455,7 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') endif; endif #endif @@ -1389,10 +1463,16 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:5),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file @@ -1471,7 +1551,7 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') endif; endif #endif @@ -1479,10 +1559,16 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:6),sum(readSize)] + !-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5screate_simple_f/memspace_id') + !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_all_coll_metadata_ops_f') !-------------------------------------------------------------------------------------------------- ! open the dataset in the file From e3d8022776640180b0b2e024171351f19af89718 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 30 Nov 2018 17:33:30 +0100 Subject: [PATCH 085/372] Read and write works for all types of data in parallel with test module passed --- src/HDF5_utilities.f90 | 317 ++++++++++++++++++----------------------- 1 file changed, 140 insertions(+), 177 deletions(-) mode change 100644 => 100755 src/HDF5_utilities.f90 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100644 new mode 100755 index ba04773d2..28a9fbde0 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -175,9 +175,19 @@ integer(HID_T) function HDF5_addGroup2(fileHandle,groupName,parallel) logical,intent(in), optional :: parallel - integer(HID_T) :: plist_id,gapl_id + integer(HID_T) :: plist_id,gapl_id, gcpl_id, aplist_id - call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr) + !------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pcreate_f ('//trim(groupName)//')') + !------------------------------------------------------------------------------------------------- +! setting I/O mode to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + !------------------------------------------------------------------------------------------------- +! Create group + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') end function HDF5_addGroup2 @@ -194,6 +204,8 @@ integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) integer(HID_T), intent(in) :: FileReadID integer(HID_T) :: aplist_id + logical :: is_collective + !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties @@ -201,7 +213,7 @@ integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pcreate_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! opening the group @@ -340,15 +352,17 @@ subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) myStart = int([sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') @@ -366,7 +380,7 @@ subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -377,6 +391,8 @@ subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal1 @@ -431,15 +447,17 @@ subroutine HDF5_read_pReal2(dataset,loc_id,datasetName,parallel) myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:1),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dopen_f') @@ -452,24 +470,26 @@ subroutine HDF5_read_pReal2(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') -end subroutine HDF5_read_pReal3 +end subroutine HDF5_read_pReal2 !-------------------------------------------------------------------------------------------------- @@ -522,15 +542,17 @@ subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:2),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dopen_f') @@ -548,7 +570,7 @@ subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -559,6 +581,8 @@ subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal3 @@ -613,16 +637,17 @@ subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:3),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dopen_f') @@ -640,7 +665,7 @@ subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -651,6 +676,8 @@ subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal4 @@ -705,17 +732,17 @@ subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(readSize)] - - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dopen_f') @@ -733,7 +760,7 @@ subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id,mem_space_id = memspace_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -744,6 +771,8 @@ subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal5 @@ -798,15 +827,17 @@ subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:5),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dopen_f') @@ -824,7 +855,7 @@ subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -835,6 +866,8 @@ subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal6 @@ -889,16 +922,17 @@ subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:6),sum(readSize)] - !-------------------------------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- ! open the dataset in the file call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dopen_f') @@ -916,7 +950,7 @@ subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -927,6 +961,8 @@ subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal7 @@ -975,7 +1011,7 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') endif; endif #endif @@ -983,12 +1019,11 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) myStart = int([sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1012,7 +1047,7 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - mem_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1023,6 +1058,8 @@ subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt1 @@ -1071,7 +1108,7 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') endif; endif #endif @@ -1079,12 +1116,11 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:1),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1108,7 +1144,7 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - mem_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1119,6 +1155,8 @@ subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt2 @@ -1167,7 +1205,7 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') endif; endif #endif @@ -1175,12 +1213,11 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:2),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1204,7 +1241,7 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1215,6 +1252,8 @@ subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt3 @@ -1263,7 +1302,7 @@ subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') endif; endif #endif @@ -1271,12 +1310,11 @@ subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:3),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1293,89 +1331,16 @@ subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dget_space_f') !-------------------------------------------------------------------------------------------------- -<<<<<<< HEAD -subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize -======= ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sselect_hyperslab_f') ->>>>>>> ab59274c357c40be21ebba6c9572df37f16dce78 !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') -<<<<<<< HEAD - logical, intent(in), optional :: parallel - integer :: ierr - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - - integer(HDF5_ERR_TYPE) :: hdferr - integer(HSIZE_T), dimension(5) :: myStart - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - - myShape = shape(dataset) - - - localShape = shape(dataset) - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(5) - -!>>>>>>>>>!New additions - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - write(6,*) plist_id -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal5: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(readSize)] - -!>>>>>>>>>!New additions -!------------------------------------------------------------------------------------------------- -! Open the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dopen_f') -!------------------------------------------------------------------------------------------------- -! get the dataspace_id of the dataset - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_5: h5dget_space_f') -!------------------------------------------------------------------------------------------------- -! select hyperslab (part to be read by the current process) - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart,int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_5: h5sselect_hyperslab_f') - write(6,*) filespace_id -!------------------------------------------------------------------------------------------------- -! read the part of the file - call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,dataset,int(myShape,HSIZE_T),hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(0_pInt,ext_msg='HDF5_read_pReal_shape5: h5dread_f') - -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') - !call h5sclose_f(filespace_id, hdferr) - !if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') - !call h5sclose_f(memspace_id, hdferr) - !if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') -======= !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) @@ -1384,9 +1349,10 @@ subroutine HDF5_read_pReal_5(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt4 ->>>>>>> ab59274c357c40be21ebba6c9572df37f16dce78 !-------------------------------------------------------------------------------------------------- @@ -1433,7 +1399,7 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') endif; endif #endif @@ -1441,12 +1407,11 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1470,7 +1435,7 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1481,6 +1446,8 @@ subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt5 @@ -1529,7 +1496,7 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') endif; endif #endif @@ -1537,12 +1504,11 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:5),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1566,7 +1532,7 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1577,6 +1543,8 @@ subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt6 @@ -1625,7 +1593,7 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') endif; endif #endif @@ -1633,12 +1601,11 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:6),sum(readSize)] - !-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5screate_simple_f/memspace_id') - + int(localShape,HSIZE_T)) +if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1662,7 +1629,7 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & - file_space_id = filespace_id, xfer_prp = plist_id) + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') !-------------------------------------------------------------------------------------------------- @@ -1673,6 +1640,8 @@ subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt7 @@ -1714,7 +1683,7 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') endif; endif #endif @@ -1802,7 +1771,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') endif; endif #endif @@ -1890,7 +1859,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') endif; endif #endif @@ -1978,7 +1947,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') endif; endif #endif @@ -2066,7 +2035,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') endif; endif #endif @@ -2154,7 +2123,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') endif; endif #endif @@ -2242,7 +2211,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') endif; endif #endif @@ -2332,7 +2301,7 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt1: MPI_allreduce') endif; endif #endif @@ -2420,7 +2389,7 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt2: MPI_allreduce') endif; endif #endif @@ -2508,7 +2477,7 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt3: MPI_allreduce') endif; endif #endif @@ -2596,7 +2565,7 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt4: MPI_allreduce') endif; endif #endif @@ -2684,7 +2653,7 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt5: MPI_allreduce') endif; endif #endif @@ -2772,7 +2741,7 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt6: MPI_allreduce') endif; endif #endif @@ -2860,7 +2829,7 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt7: MPI_allreduce') endif; endif #endif @@ -2915,9 +2884,3 @@ end module HDF5_Utilities !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - - - From 801e472497e08fc8edf9728708d72786191c1aa7 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 30 Nov 2018 17:34:26 +0100 Subject: [PATCH 086/372] Made it non-executable --- src/HDF5_utilities.f90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 src/HDF5_utilities.f90 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100755 new mode 100644 From ecb00af1470bb122437e9c5bdc3f0b891096d184 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 4 Dec 2018 23:09:25 +0100 Subject: [PATCH 087/372] cleaning and separating functions --- src/CPFEM2.f90 | 49 +++++++++++++------------- src/HDF5_utilities.f90 | 78 +++++++++++++++++++++--------------------- src/results.f90 | 43 +++++++++-------------- 3 files changed, 82 insertions(+), 88 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 126e9240b..54774cf59 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -108,8 +108,7 @@ subroutine CPFEM_init debug_levelBasic, & debug_levelExtensive use FEsolving, only: & - restartRead, & - modelName + restartRead use material, only: & material_phase, & homogState, & @@ -128,16 +127,17 @@ subroutine CPFEM_init use hdf5 use HDF5_utilities, only: & HDF5_openFile, & - HDF5_openGroup2, & + HDF5_closeFile, & + HDF5_openGroup, & + HDF5_closeGroup, & HDF5_read use DAMASK_interface, only: & getSolverJobName implicit none - integer(pInt) :: k,l,m,ph,homog + integer(pInt) :: ph,homog character(len=1024) :: rankStr, PlasticItem, HomogItem - integer(HID_T) :: fileReadID, groupPlasticID, groupHomogID - integer :: hdferr + integer(HID_T) :: fileHandle, groupPlasticID, groupHomogID mainProcess: if (worldrank == 0) then write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' @@ -155,28 +155,33 @@ subroutine CPFEM_init write(rankStr,'(a1,i0)')'_',worldrank - fileReadID = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - call HDF5_read(material_phase, fileReadID,'recordedPhase') - call HDF5_read(crystallite_F0, fileReadID,'convergedF') - call HDF5_read(crystallite_Fp0, fileReadID,'convergedFp') - call HDF5_read(crystallite_Fi0, fileReadID,'convergedFi') - call HDF5_read(crystallite_Lp0, fileReadID,'convergedLp') - call HDF5_read(crystallite_Li0, fileReadID,'convergedLi') - call HDF5_read(crystallite_dPdF0, fileReadID,'convergeddPdF') - call HDF5_read(crystallite_Tstar0_v,fileReadID,'convergedTstar') + call HDF5_read(material_phase, fileHandle,'recordedPhase') + call HDF5_read(crystallite_F0, fileHandle,'convergedF') + call HDF5_read(crystallite_Fp0, fileHandle,'convergedFp') + call HDF5_read(crystallite_Fi0, fileHandle,'convergedFi') + call HDF5_read(crystallite_Lp0, fileHandle,'convergedLp') + call HDF5_read(crystallite_Li0, fileHandle,'convergedLi') + call HDF5_read(crystallite_dPdF0, fileHandle,'convergeddPdF') + call HDF5_read(crystallite_Tstar0_v,fileHandle,'convergedTstar') - groupPlasticID = HDF5_openGroup2(fileReadID,'PlasticPhases') + groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') do ph = 1_pInt,size(phase_plasticity) write(PlasticItem,*) ph,'_' call HDF5_read(plasticState(ph)%state0,groupPlasticID,trim(PlasticItem)//'convergedStateConst') enddo + call HDF5_closeGroup(groupPlasticID) - groupHomogID = HDF5_openGroup2(fileReadID,'HomogStates') + groupHomogID = HDF5_openGroup(fileHandle,'HomogStates') do homog = 1_pInt, material_Nhomogenization write(HomogItem,*) homog,'_' call HDF5_read(homogState(homog)%state0, groupHomogID,trim(HomogItem)//'convergedStateHomog') enddo + call HDF5_closeGroup(groupHomogID) + + + call HDF5_closeFile(fileHandle) restartRead = .false. endif @@ -234,8 +239,8 @@ subroutine CPFEM_age() use HDF5_utilities, only: & HDF5_openFile, & HDF5_closeFile, & + HDF5_addGroup, & HDF5_closeGroup, & - HDF5_addGroup2, & HDF5_write use hdf5 use DAMASK_interface, only: & @@ -243,11 +248,9 @@ subroutine CPFEM_age() implicit none - integer(pInt) :: i, k, l, m, ph, homog, mySource + integer(pInt) :: i, ph, homog, mySource character(len=32) :: rankStr, PlasticItem, HomogItem integer(HID_T) :: fileHandle, groupPlastic, groupHomog - integer :: hdferr - integer(HSIZE_T) :: hdfsize if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & write(6,'(a)') '<< CPFEM >> aging states' @@ -291,14 +294,14 @@ if (restartWrite) then call HDF5_write(crystallite_dPdF0, fileHandle,'convergeddPdF') call HDF5_write(crystallite_Tstar0_v,fileHandle,'convergedTstar') - groupPlastic = HDF5_addGroup2(fileHandle,'PlasticPhases') + groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') do ph = 1_pInt,size(phase_plasticity) write(PlasticItem,*) ph,'_' call HDF5_write(plasticState(ph)%state0,groupPlastic,trim(PlasticItem)//'convergedStateConst') enddo call HDF5_closeGroup(groupPlastic) - groupHomog = HDF5_addGroup2(fileHandle,'HomogStates') + groupHomog = HDF5_addGroup(fileHandle,'HomogStates') do homog = 1_pInt, material_Nhomogenization write(HomogItem,*) homog,'_' call HDF5_write(homogState(homog)%state0,groupHomog,trim(HomogItem)//'convergedStateHomog') diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 28a9fbde0..144bc9098 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -68,8 +68,8 @@ module HDF5_utilities HDF5_addStringAttribute, & HDF5_addIntegerAttribute, & HDF5_closeGroup ,& - HDF5_openGroup2, & - HDF5_addGroup2, & + HDF5_openGroup, & + HDF5_addGroup, & HDF5_read, & HDF5_write contains @@ -154,9 +154,10 @@ end function HDF5_openFile subroutine HDF5_closeFile(fileHandle) implicit none - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: fileHandle + integer(HDF5_ERR_TYPE) :: hdferr + call h5fclose_f(fileHandle,hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') @@ -164,63 +165,66 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- -!> @brief adds a new group to the fileHandle (additional to addGroup2) +!> @brief adds a new group to the fileHandle !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup2(fileHandle,groupName,parallel) +integer(HID_T) function HDF5_addGroup(fileHandle,groupName) implicit none - character(len=*), intent(in) :: groupName integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: groupName + integer(HDF5_ERR_TYPE) :: hdferr - - logical,intent(in), optional :: parallel - - integer(HID_T) :: plist_id,gapl_id, gcpl_id, aplist_id + integer(HID_T) :: aplist_id !------------------------------------------------------------------------------------------------- -! creating a property list for data access properties + ! creating a property list for data access properties call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pcreate_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- -! setting I/O mode to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- -! Create group - call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup2, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup2: h5gcreate_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') -end function HDF5_addGroup2 + !------------------------------------------------------------------------------------------------- + ! setting I/O mode to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + + !------------------------------------------------------------------------------------------------- + ! Create group + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') + +end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- !> @brief open an existing group of a file !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openGroup2(FileReadID,groupName) +integer(HID_T) function HDF5_openGroup(fileHandle,groupName) implicit none + integer(HID_T), intent(in) :: fileHandle character(len=*), intent(in) :: groupName - integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T), intent(in) :: FileReadID + + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: aplist_id logical :: is_collective !------------------------------------------------------------------------------------------------- -! creating a property list for data access properties + ! creating a property list for data access properties call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pcreate_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- -! setting I/O mode to collective - call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- -! opening the group - call h5gopen_f(FileReadID, trim(groupName), HDF5_openGroup2, hdferr, gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup2: h5gopen_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') -end function HDF5_openGroup2 + !------------------------------------------------------------------------------------------------- + ! setting I/O mode to collective + call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + + !------------------------------------------------------------------------------------------------- + ! opening the group + call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + +end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- @@ -2880,7 +2884,3 @@ end subroutine HDF5_write_pInt7 end module HDF5_Utilities - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - diff --git a/src/results.f90 b/src/results.f90 index 2a695c55c..ae78ab8c1 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -31,9 +31,8 @@ module results HDF5_backwardMappingHomog, & HDF5_backwardMappingCrystallite, & HDF5_mappingCells, & - HDF5_addGroup ,& - HDF5_closeGroup ,& - HDF5_openGroup, & + results_addGroup, & + results_openGroup, & HDF5_writeVectorDataset, & HDF5_writeScalarDataset, & HDF5_writeTensorDataset, & @@ -72,8 +71,6 @@ end subroutine results_openJobFile !> @brief closes the results file !-------------------------------------------------------------------------------------------------- subroutine results_closeJobFile() - use DAMASK_interface, only: & - getSolverJobName implicit none call HDF5_closeFile(resultsFile) @@ -94,33 +91,27 @@ end subroutine results_addIncrement !-------------------------------------------------------------------------------------------------- !> @brief open a group from the results file !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_openGroup(groupName) - use hdf5 +integer(HID_T) function results_openGroup(groupName) implicit none character(len=*), intent(in) :: groupName - integer :: hdferr + + results_openGroup = HDF5_openGroup(resultsFile,groupName) - call h5gopen_f(resultsFile, trim(groupName), HDF5_openGroup, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') - -end function HDF5_openGroup +end function results_openGroup !-------------------------------------------------------------------------------------------------- !> @brief adds a new group to the results file !-------------------------------------------------------------------------------------------------- -integer(HID_T) function HDF5_addGroup(groupName) - use hdf5 +integer(HID_T) function results_addGroup(groupName) implicit none character(len=*), intent(in) :: groupName - integer :: hdferr + + results_addGroup = HDF5_addGroup(resultsFile,groupName) - call h5gcreate_f(resultsFile, trim(groupName), HDF5_addGroup, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') - -end function HDF5_addGroup +end function results_addGroup !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file @@ -189,7 +180,7 @@ subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase a = n allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) NmatPoints = size(mapping,1)/Nconstituents - mapping_ID = HDF5_openGroup("current/mapGeometry") + mapping_ID = results_openGroup("current/mapGeometry") allocate(arrOffset(Nconstituents,NmatPoints)) do i=1_pInt, NmatPoints @@ -336,7 +327,7 @@ subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dat do i=1_pInt, size(phase_name) write(phaseID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) + mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) NmatPoints = count(material_phase == i) !-------------------------------------------------------------------------------------------------- @@ -436,7 +427,7 @@ subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,da integer(pInt), dimension(:), allocatable :: arrOffset NmatPoints = count(material_homog /=0_pInt) - mapping_ID = HDF5_openGroup("current/mapGeometry") + mapping_ID = results_openGroup("current/mapGeometry") allocate(arrOffset(NmatPoints)) do i=1_pInt, NmatPoints @@ -573,7 +564,7 @@ subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization do i=1_pInt, size(homogenization_name) write(homogID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) + mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) !-------------------------------------------------------------------------------------------------- ! create dataspace @@ -679,7 +670,7 @@ subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name, Nconstituents = size(crystmemberAt,1) NmatPoints = count(crystalliteAt /=0_pInt) - mapping_ID = HDF5_openGroup("current/mapGeometry") + mapping_ID = results_openGroup("current/mapGeometry") allocate(position_id(Nconstituents)) @@ -842,7 +833,7 @@ subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystalli do i=1_pInt, size(crystallite_name) if (crystallite_name(i) == 'none') cycle write(crystallID, '(i0)') i - mapping_ID = HDF5_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) + mapping_ID = results_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) NmatPoints = count(crystalliteAt == i) !-------------------------------------------------------------------------------------------------- @@ -933,7 +924,7 @@ subroutine HDF5_mappingCells(mapping) integer(HID_T) :: mapping_id, dset_id, space_id Nnodes=size(mapping) - mapping_ID = HDF5_openGroup("mapping") + mapping_ID = results_openGroup("mapping") !-------------------------------------------------------------------------------------------------- ! create dataspace From adffe41ffe5534d0a1adb8f5334736c44d05925d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 4 Dec 2018 23:55:39 +0100 Subject: [PATCH 088/372] writing group structure in file root --- src/CPFEM2.f90 | 156 ++++++++++++++++++++++------------------ src/DAMASK_spectral.f90 | 4 +- src/constitutive.f90 | 11 ++- 3 files changed, 101 insertions(+), 70 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 54774cf59..731fcf231 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -10,8 +10,8 @@ module CPFEM2 public :: & CPFEM_age, & - CPFEM_initAll - + CPFEM_initAll, & + CPFEM_results contains @@ -20,8 +20,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine CPFEM_initAll() use prec, only: & - pInt - use prec, only: & + pInt, & prec_init use numerics, only: & numerics_init @@ -139,12 +138,10 @@ subroutine CPFEM_init character(len=1024) :: rankStr, PlasticItem, HomogItem integer(HID_T) :: fileHandle, groupPlasticID, groupHomogID - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - flush(6) - endif mainProcess + flush(6) ! *** restore the last converged values of each essential variable from the binary file if (restartRead) then @@ -188,6 +185,7 @@ subroutine CPFEM_init end subroutine CPFEM_init + !-------------------------------------------------------------------------------------------------- !> @brief forwards data after successful increment !-------------------------------------------------------------------------------------------------- @@ -247,74 +245,96 @@ subroutine CPFEM_age() getSolverJobName implicit none - integer(pInt) :: i, ph, homog, mySource character(len=32) :: rankStr, PlasticItem, HomogItem integer(HID_T) :: fileHandle, groupPlastic, groupHomog -if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & - write(6,'(a)') '<< CPFEM >> aging states' + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> aging states' - crystallite_F0 = crystallite_partionedF ! crystallite deformation (_subF is perturbed...) - crystallite_Fp0 = crystallite_Fp ! crystallite plastic deformation - crystallite_Lp0 = crystallite_Lp ! crystallite plastic velocity - crystallite_Fi0 = crystallite_Fi ! crystallite intermediate deformation - crystallite_Li0 = crystallite_Li ! crystallite intermediate velocity - crystallite_dPdF0 = crystallite_dPdF ! crystallite stiffness - crystallite_Tstar0_v = crystallite_Tstar_v ! crystallite 2nd Piola Kirchhoff stress - - forall (i = 1:size(plasticState)) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lengthy way because: A component cannot be an array if the encompassing structure is an array - - do i = 1, size(sourceState) - do mySource = 1,phase_Nsources(i) - sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state ! copy state in this lengthy way because: A component cannot be an array if the encompassing structure is an array - enddo; enddo - - do homog = 1_pInt, material_Nhomogenization - homogState (homog)%state0 = homogState (homog)%state - thermalState (homog)%state0 = thermalState (homog)%state - damageState (homog)%state0 = damageState (homog)%state - vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state - hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state - enddo + crystallite_F0 = crystallite_partionedF + crystallite_Fp0 = crystallite_Fp + crystallite_Lp0 = crystallite_Lp + crystallite_Fi0 = crystallite_Fi + crystallite_Li0 = crystallite_Li + crystallite_dPdF0 = crystallite_dPdF + crystallite_Tstar0_v = crystallite_Tstar_v + + forall (i = 1:size(plasticState)) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lengthy way because: A component cannot be an array if the encompassing structure is an array + + do i = 1, size(sourceState) + do mySource = 1,phase_Nsources(i) + sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state ! copy state in this lengthy way because: A component cannot be an array if the encompassing structure is an array + enddo; enddo + + do homog = 1_pInt, material_Nhomogenization + homogState (homog)%state0 = homogState (homog)%state + thermalState (homog)%state0 = thermalState (homog)%state + damageState (homog)%state0 = damageState (homog)%state + vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state + hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state + enddo -if (restartWrite) then - if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & - write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' - write(rankStr,'(a1,i0)')'_',worldrank + if (restartWrite) then + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + call HDF5_write(material_phase, fileHandle,'recordedPhase') + call HDF5_write(crystallite_F0, fileHandle,'convergedF') + call HDF5_write(crystallite_Fp0, fileHandle,'convergedFp') + call HDF5_write(crystallite_Fi0, fileHandle,'convergedFi') + call HDF5_write(crystallite_Lp0, fileHandle,'convergedLp') + call HDF5_write(crystallite_Li0, fileHandle,'convergedLi') + call HDF5_write(crystallite_dPdF0, fileHandle,'convergeddPdF') + call HDF5_write(crystallite_Tstar0_v,fileHandle,'convergedTstar') + + groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') + do ph = 1_pInt,size(phase_plasticity) + write(PlasticItem,*) ph,'_' + call HDF5_write(plasticState(ph)%state0,groupPlastic,trim(PlasticItem)//'convergedStateConst') + enddo + call HDF5_closeGroup(groupPlastic) - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - - call HDF5_write(material_phase, fileHandle,'recordedPhase') - call HDF5_write(crystallite_F0, fileHandle,'convergedF') - call HDF5_write(crystallite_Fp0, fileHandle,'convergedFp') - call HDF5_write(crystallite_Fi0, fileHandle,'convergedFi') - call HDF5_write(crystallite_Lp0, fileHandle,'convergedLp') - call HDF5_write(crystallite_Li0, fileHandle,'convergedLi') - call HDF5_write(crystallite_dPdF0, fileHandle,'convergeddPdF') - call HDF5_write(crystallite_Tstar0_v,fileHandle,'convergedTstar') - - groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') - do ph = 1_pInt,size(phase_plasticity) - write(PlasticItem,*) ph,'_' - call HDF5_write(plasticState(ph)%state0,groupPlastic,trim(PlasticItem)//'convergedStateConst') - enddo - call HDF5_closeGroup(groupPlastic) + groupHomog = HDF5_addGroup(fileHandle,'HomogStates') + do homog = 1_pInt, material_Nhomogenization + write(HomogItem,*) homog,'_' + call HDF5_write(homogState(homog)%state0,groupHomog,trim(HomogItem)//'convergedStateHomog') + enddo + call HDF5_closeGroup(groupHomog) + + call HDF5_closeFile(fileHandle) + restartWrite = .false. + endif - groupHomog = HDF5_addGroup(fileHandle,'HomogStates') - do homog = 1_pInt, material_Nhomogenization - write(HomogItem,*) homog,'_' - call HDF5_write(homogState(homog)%state0,groupHomog,trim(HomogItem)//'convergedStateHomog') - enddo - call HDF5_closeGroup(groupHomog) - - call HDF5_closeFile(fileHandle) - restartWrite = .false. -endif - -if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & - write(6,'(a)') '<< CPFEM >> done aging states' + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> done aging states' end subroutine CPFEM_age +!-------------------------------------------------------------------------------------------------- +!> @brief triggers writing of the results +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_results(inc) + use prec, only: & + pInt + use results + use HDF5_utilities + use constitutive, only: & + constitutive_results + + implicit none + integer(pInt), intent(in) :: inc + character(len=16) :: incChar + + call results_openJobFile + write(incChar,*) inc + call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call constitutive_results() + call results_closeJobFile + +end subroutine CPFEM_results + end module CPFEM2 diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 index 1e75f2761..74e81f126 100644 --- a/src/DAMASK_spectral.f90 +++ b/src/DAMASK_spectral.f90 @@ -46,7 +46,8 @@ program DAMASK_spectral grid, & geomSize use CPFEM2, only: & - CPFEM_initAll + CPFEM_initAll, & + CPFEM_results use FEsolving, only: & restartWrite, & restartInc @@ -601,6 +602,7 @@ program DAMASK_spectral if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') enddo fileOffset = fileOffset + sum(outputSize) ! forward to current file position + call CPFEM_results(inc) endif if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information diff --git a/src/constitutive.f90 b/src/constitutive.f90 index eca8af08a..cbb072471 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -25,7 +25,8 @@ module constitutive constitutive_SandItsTangents, & constitutive_collectDotState, & constitutive_collectDeltaState, & - constitutive_postResults + constitutive_postResults, & + constitutive_results private :: & constitutive_hooke_SandItsTangents @@ -1179,4 +1180,12 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) end function constitutive_postResults + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_results() + +end subroutine constitutive_results + end module constitutive From 0ed1bd11bd0e307401aba34a2a1947e22e895156 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 5 Dec 2018 13:51:24 +0100 Subject: [PATCH 089/372] need to write out total increments otherwise, group/folder of the same name would exist --- src/DAMASK_spectral.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 index 74e81f126..781598f3d 100644 --- a/src/DAMASK_spectral.f90 +++ b/src/DAMASK_spectral.f90 @@ -602,7 +602,7 @@ program DAMASK_spectral if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') enddo fileOffset = fileOffset + sum(outputSize) ! forward to current file position - call CPFEM_results(inc) + call CPFEM_results(totalIncsCounter) endif if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information From 8424ba76ac814bdea8f0405ad9e6f83d2f224006 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 9 Dec 2018 20:54:49 +0100 Subject: [PATCH 090/372] never used --- src/lattice.f90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index bdb52bc8d..01df2a00a 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -52,8 +52,7 @@ module lattice lattice_st, & !< sd x sn lattice_sd, & !< slip direction of slip system lattice_Stwin_v, & - lattice_Strans_v, & !< Eigendeformation tensor in vector form - lattice_projectionTrans !< Matrix for projection of slip to fault-band (twin) systems for strain-induced martensite nucleation + lattice_Strans_v !< Eigendeformation tensor in vector form real(pReal), allocatable, dimension(:,:), protected, public :: & lattice_shearTwin, & !< characteristic twin shear @@ -1353,7 +1352,6 @@ subroutine lattice_init allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_Strans_v(6,lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(lattice_projectionTrans(lattice_maxNtrans,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_NslipSystem(lattice_maxNslipFamily,Nphases),source=0_pInt) allocate(lattice_NtwinSystem(lattice_maxNtwinFamily,Nphases),source=0_pInt) @@ -1701,8 +1699,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fccTohex_interactionSlipTrans lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fccTohex_interactionTransSlip lattice_interactionTransTrans(1:myNtrans,1:myNtrans,myPhase) = lattice_fccTohex_interactionTransTrans - lattice_projectionTrans(1:myNtrans,1:myNtrans,myPhase) = LATTICE_fccTobcc_projectionTrans*& - LATTICE_fccTobcc_projectionTransFactor !-------------------------------------------------------------------------------------------------- ! bcc From 1b571d33a76e8a59a0c3ac91011c6fb1996ab378 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 9 Dec 2018 21:10:14 +0100 Subject: [PATCH 091/372] using trans-trans interactions from lattice --- src/lattice.f90 | 8 ++++++-- src/plastic_dislotwin.f90 | 26 ++++---------------------- 2 files changed, 10 insertions(+), 24 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 01df2a00a..49601d548 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -1268,6 +1268,7 @@ real(pReal), dimension(4,36), parameter, private :: & lattice_interaction_TwinTwin, & lattice_interaction_SlipTwin, & lattice_interaction_TwinSlip, & + lattice_interaction_TransTrans, & lattice_characteristicShear_Twin contains @@ -2570,6 +2571,9 @@ function lattice_interaction_TransTrans(Ntrans,interactionValues,structure,targe if (trim(structure) == 'fcc' .and. trim(targetStructure) == 'hex') then interactionTypes = lattice_fccToHex_interactionTransTrans NtransMax = lattice_fcc_Ntrans + elseif (trim(structure) == 'fcc' .and. trim(targetStructure) == 'bcc') then + interactionTypes = lattice_fccToHex_interactionTransTrans !< ToDo: The definition for bcc does not exist yet + NtransMax = lattice_fcc_Ntrans else call IO_error(132_pInt,ext_msg=trim(structure)//' => '//trim(targetStructure)) end if @@ -2827,7 +2831,7 @@ function buildCoordinateSystem(active,maximum,system,structure,cOverA) normal = system(4:6,j) case ('hex') - !ToDo: check c/a ratio + !ToDo: check if c/a ratio is sensible ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) direction = [ system(1,j)*1.5_pReal, & (system(1,j)+2.0_pReal*system(2,j))*sqrt(0.75_pReal), & @@ -2839,7 +2843,7 @@ function buildCoordinateSystem(active,maximum,system,structure,cOverA) system(8,j)/CoverA ] case ('bct') - !ToDo: check c/a ratio + !ToDo: check if c/a ratio is sensible direction = [system(1:2,j),system(3,i)*CoverA] normal = [system(4:5,j),system(6,i)/CoverA] diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 00534d251..475721c57 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -245,14 +245,6 @@ subroutine plastic_dislotwin_init(fileUnit) real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - type(tParameters) :: & - prm - type(tDislotwinState) :: & - stt, & - dot - type(tDislotwinMicrostructure) :: & - mse - integer(kind(undefined_ID)) :: & outputID !< ID of each post result output @@ -411,7 +403,10 @@ subroutine plastic_dislotwin_init(fileUnit) prm%xc_trans = config_phase(p)%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? prm%L0_trans = config_phase(p)%getFloat('l0_trans') - prm%interaction_TransTrans = spread(config_phase(p)%getFloats('interaction_transtrans'),2,1) + prm%interaction_TransTrans = lattice_interaction_TransTrans(prm%Ntrans,& + config_phase(p)%getFloats('interaction_transtrans'), & + structure(1:3),& + trim(config_phase(p)%getString('trans_lattice_structure'))) if (lattice_structure(p) /= LATTICE_fcc_ID) then prm%Ndot0_trans = config_phase(p)%getFloats('ndot0_trans') prm%Ndot0_trans = math_expand(prm%Ndot0_trans,prm%Ntrans) @@ -651,7 +646,6 @@ subroutine plastic_dislotwin_init(fileUnit) allocate(temp1(prm%totalNtrans,prm%totalNslip), source =0.0_pReal) - allocate(temp2(prm%totalNtrans,prm%totalNtrans), source =0.0_pReal) allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) i = 0_pInt @@ -675,21 +669,9 @@ subroutine plastic_dislotwin_init(fileUnit) sum(lattice_NslipSystem(1:o-1_pInt,p))+k, & p) ,1 ) enddo; enddo - - do o = 1_pInt,size(prm%Ntrans,1) - index_otherFamily = sum(prm%Ntrans(1:o-1_pInt)) - do k = 1_pInt,prm%Ntrans(o) ! loop over (active) systems in other family (trans) - temp2(index_myFamily+j,index_otherFamily+k) = & - prm%interaction_TransTrans(lattice_interactionTransTrans( & - sum(lattice_NtransSystem(1:f-1_pInt,p))+j, & - sum(lattice_NtransSystem(1:o-1_pInt,p))+k, & - p),1 ) - enddo; enddo - enddo transSystemsLoop enddo transFamiliesLoop prm%interaction_TransSlip = temp1; deallocate(temp1) - prm%interaction_TransTrans = temp2; deallocate(temp2) startIndex=1_pInt endIndex=prm%totalNslip From 95826d094c4ff60a8eff7f554a7da1faa574b604 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 9 Dec 2018 22:00:04 +0100 Subject: [PATCH 092/372] not needed anymore --- src/lattice.f90 | 33 ++------------------------------- 1 file changed, 2 insertions(+), 31 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 49601d548..d55049808 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -28,12 +28,9 @@ module lattice integer(pInt), allocatable, dimension(:,:,:), protected, public :: & lattice_interactionSlipSlip, & !< Slip--slip interaction type - lattice_interactionSlipTwin, & !< Slip--twin interaction type - lattice_interactionTwinSlip, & !< Twin--slip interaction type - lattice_interactionTwinTwin, & !< Twin--twin interaction type lattice_interactionSlipTrans, & !< Slip--trans interaction type - lattice_interactionTransSlip, & !< Trans--slip interaction type - lattice_interactionTransTrans !< Trans--trans interaction type + lattice_interactionTransSlip !< Trans--slip interaction type + real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & lattice_Sslip, & !< Schmid and non-Schmid matrices @@ -44,14 +41,12 @@ module lattice lattice_Scleavage_v, & !< Mandel notation of lattice_Scleavege lattice_Qtrans, & !< Total rotation: Q = R*B lattice_Strans, & !< Eigendeformation tensor for phase transformation - lattice_Stwin, & lattice_Qtwin real(pReal), allocatable, dimension(:,:,:), protected, public :: & lattice_sn, & !< normal direction of slip system lattice_st, & !< sd x sn lattice_sd, & !< slip direction of slip system - lattice_Stwin_v, & lattice_Strans_v !< Eigendeformation tensor in vector form real(pReal), allocatable, dimension(:,:), protected, public :: & @@ -1344,8 +1339,6 @@ subroutine lattice_init allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_Qtwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_Stwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_Stwin_v(6,lattice_maxNtwin,Nphases),source=0.0_pReal) allocate(lattice_shearTwin(lattice_maxNtwin,Nphases),source=0.0_pReal) allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) @@ -1360,12 +1353,8 @@ subroutine lattice_init allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionSlipTwin(lattice_maxNslip,lattice_maxNtwin,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionTwinSlip(lattice_maxNtwin,lattice_maxNslip,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionTwinTwin(lattice_maxNtwin,lattice_maxNtwin,Nphases),source=0_pInt) ! other:me allocate(lattice_interactionSlipTrans(lattice_maxNslip,lattice_maxNtrans,Nphases),source=0_pInt) ! other:me allocate(lattice_interactionTransSlip(lattice_maxNtrans,lattice_maxNslip,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionTransTrans(lattice_maxNtrans,lattice_maxNtrans,Nphases),source=0_pInt) ! other:me allocate(CoverA(Nphases),source=0.0_pReal) allocate(CoverA_trans(Nphases),source=0.0_pReal) @@ -1694,12 +1683,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem lattice_NnonSchmid(myPhase) = lattice_fcc_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip - lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_fcc_interactionSlipTwin - lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_fcc_interactionTwinSlip - lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_fcc_interactionTwinTwin lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fccTohex_interactionSlipTrans lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fccTohex_interactionTransSlip - lattice_interactionTransTrans(1:myNtrans,1:myNtrans,myPhase) = lattice_fccTohex_interactionTransTrans !-------------------------------------------------------------------------------------------------- ! bcc @@ -1746,9 +1731,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bcc_NcleavageSystem lattice_NnonSchmid(myPhase) = lattice_bcc_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bcc_interactionSlipSlip - lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_bcc_interactionSlipTwin - lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_bcc_interactionTwinSlip - lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_bcc_interactionTwinTwin !-------------------------------------------------------------------------------------------------- ! hex (including conversion from miller-bravais (a1=a2=a3=c) to miller (a, b, c) indices) @@ -1803,9 +1785,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem lattice_NnonSchmid(myPhase) = lattice_hex_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip - lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_hex_interactionSlipTwin - lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_hex_interactionTwinSlip - lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_hex_interactionTwinTwin !-------------------------------------------------------------------------------------------------- ! bct @@ -1882,17 +1861,9 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) call IO_error(0_pInt,myPhase,i,0_pInt,ext_msg = 'dilatational slip Schmid matrix') enddo do i = 1_pInt,myNtwin ! store twin system vectors and Schmid plus rotation matrix for my structure - lattice_td(1:3,i,myPhase) = td(1:3,i)/norm2(td(1:3,i)) ! make unit vector lattice_tn(1:3,i,myPhase) = tn(1:3,i)/norm2(tn(1:3,i)) ! make unit vector - lattice_tt(1:3,i,myPhase) = math_crossproduct(lattice_td(1:3,i,myPhase), & - lattice_tn(1:3,i,myPhase)) - lattice_Stwin(1:3,1:3,i,myPhase) = math_tensorproduct33(lattice_td(1:3,i,myPhase), & - lattice_tn(1:3,i,myPhase)) - lattice_Stwin_v(1:6,i,myPhase) = math_Mandel33to6(math_symmetric33(lattice_Stwin(1:3,1:3,i,myPhase))) lattice_Qtwin(1:3,1:3,i,myPhase) = math_axisAngleToR(tn(1:3,i),180.0_pReal*INRAD) lattice_shearTwin(i,myPhase) = ts(i) - if (abs(math_trace33(lattice_Stwin(1:3,1:3,i,myPhase))) > tol_math_check) & - call IO_error(301_pInt,myPhase,ext_msg = 'dilatational twin Schmid matrix') enddo do i = 1_pInt,myNtrans lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) From 0f106e77d99313d60e3dd3029d10dafba0a02183 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 9 Dec 2018 22:20:18 +0100 Subject: [PATCH 093/372] cleaning --- src/lattice.f90 | 43 ++++++--------------------------------- src/plastic_dislotwin.f90 | 9 ++++---- 2 files changed, 11 insertions(+), 41 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index d55049808..69b0de5a6 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -50,16 +50,11 @@ module lattice lattice_Strans_v !< Eigendeformation tensor in vector form real(pReal), allocatable, dimension(:,:), protected, public :: & - lattice_shearTwin, & !< characteristic twin shear lattice_shearTrans !< characteristic transformation shear integer(pInt), allocatable, dimension(:), protected, public :: & lattice_NnonSchmid !< total # of non-Schmid contributions for each structure - real(pReal), allocatable, dimension(:,:,:), private :: & - lattice_tn, & - lattice_td, & - lattice_tt ! END DEPRECATED @@ -1340,7 +1335,6 @@ subroutine lattice_init allocate(lattice_Qtwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_shearTwin(lattice_maxNtwin,Nphases),source=0.0_pReal) allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) @@ -1361,9 +1355,6 @@ subroutine lattice_init allocate(a_fcc(Nphases),source=0.0_pReal) allocate(a_bcc(Nphases),source=0.0_pReal) - allocate(lattice_td(3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_tt(3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_tn(3,lattice_maxNtwin,Nphases),source=0.0_pReal) allocate(lattice_sd(3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_st(3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_sn(3,lattice_maxNslip,Nphases),source=0.0_pReal) @@ -1518,8 +1509,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sns real(pReal), dimension(3,lattice_maxNtwin) :: & td, tn - real(pReal), dimension(lattice_maxNtwin) :: & - ts real(pReal), dimension(lattice_maxNtrans) :: & trs real(pReal), dimension(3,lattice_maxNtrans) :: & @@ -1622,9 +1611,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sn(1:3,i) = lattice_fcc_systemSlip(4:6,i) enddo do i = 1_pInt,myNtwin ! assign twin system vectors and shears - td(1:3,i) = lattice_fcc_systemTwin(1:3,i) tn(1:3,i) = lattice_fcc_systemTwin(4:6,i) - ts(i) = lattice_fcc_shearTwin(i) enddo do i = 1_pInt, myNcleavage ! assign cleavage system vectors cd(1:3,i) = lattice_fcc_systemCleavage(1:3,i)/norm2(lattice_fcc_systemCleavage(1:3,i)) @@ -1716,9 +1703,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sns(1:3,1:3,2,6,i) = math_tensorproduct33(-sdU, -sdU) enddo do i = 1_pInt,myNtwin ! assign twin system vectors and shears - td(1:3,i) = lattice_bcc_systemTwin(1:3,i) tn(1:3,i) = lattice_bcc_systemTwin(4:6,i) - ts(i) = lattice_bcc_shearTwin(i) enddo do i = 1_pInt, myNcleavage ! assign cleavage system vectors cd(1:3,i) = lattice_bcc_systemCleavage(1:3,i)/norm2(lattice_bcc_systemCleavage(1:3,i)) @@ -1749,23 +1734,9 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sn(3,i) = lattice_hex_systemSlip(8,i)/CoverA enddo do i = 1_pInt,myNtwin ! assign twin system vectors and shears - td(1,i) = lattice_hex_systemTwin(1,i)*1.5_pReal - td(2,i) = (lattice_hex_systemTwin(1,i)+2.0_pReal*lattice_hex_systemTwin(2,i))*& - 0.5_pReal*sqrt(3.0_pReal) - td(3,i) = lattice_hex_systemTwin(4,i)*CoverA tn(1,i) = lattice_hex_systemTwin(5,i) tn(2,i) = (lattice_hex_systemTwin(5,i)+2.0_pReal*lattice_hex_systemTwin(6,i))/sqrt(3.0_pReal) tn(3,i) = lattice_hex_systemTwin(8,i)/CoverA - select case(lattice_hex_shearTwin(i)) ! from Christian & Mahajan 1995 p.29 - case (1_pInt) ! <-10.1>{10.2} - ts(i) = (3.0_pReal-CoverA*CoverA)/sqrt(3.0_pReal)/CoverA - case (2_pInt) ! <11.6>{-1-1.1} - ts(i) = 1.0_pReal/CoverA - case (3_pInt) ! <10.-2>{10.1} - ts(i) = (4.0_pReal*CoverA*CoverA-9.0_pReal)/4.0_pReal/sqrt(3.0_pReal)/CoverA - case (4_pInt) ! <11.-3>{11.2} - ts(i) = 2.0_pReal*(CoverA*CoverA-2.0_pReal)/3.0_pReal/CoverA - end select enddo do i = 1_pInt, myNcleavage ! cleavage system vectors cd(1,i) = lattice_hex_systemCleavage(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] @@ -1861,9 +1832,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) call IO_error(0_pInt,myPhase,i,0_pInt,ext_msg = 'dilatational slip Schmid matrix') enddo do i = 1_pInt,myNtwin ! store twin system vectors and Schmid plus rotation matrix for my structure - lattice_tn(1:3,i,myPhase) = tn(1:3,i)/norm2(tn(1:3,i)) ! make unit vector lattice_Qtwin(1:3,1:3,i,myPhase) = math_axisAngleToR(tn(1:3,i),180.0_pReal*INRAD) - lattice_shearTwin(i,myPhase) = ts(i) enddo do i = 1_pInt,myNtrans lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) @@ -2181,7 +2150,7 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) lattice_C66_twin(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(math_Mandel66to3333(C66),R)) enddo -end function +end function lattice_C66_twin !-------------------------------------------------------------------------------------------------- @@ -2716,11 +2685,11 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) - do i = 1, sum(Ncleavage) - SchmidMatrix(1:3,1:3,1,i) = math_tensorproduct33(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,2,i) = math_tensorproduct33(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,3,i) = math_tensorproduct33(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) - enddo + do i = 1, sum(Ncleavage) + SchmidMatrix(1:3,1:3,1,i) = math_tensorproduct33(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,2,i) = math_tensorproduct33(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,3,i) = math_tensorproduct33(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) + enddo end function lattice_SchmidMatrix_cleavage diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 475721c57..0913feb44 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -239,7 +239,7 @@ subroutine plastic_dislotwin_init(fileUnit) integer(pInt) :: sizeState, sizeDotState integer(pInt) :: NipcMyPhase - real(pReal), allocatable, dimension(:,:) :: temp1,temp2 + real(pReal), allocatable, dimension(:,:) :: temp1 integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] @@ -371,6 +371,9 @@ subroutine plastic_dislotwin_init(fileUnit) prm%Cthresholdtwin = config_phase(p)%getFloat('cthresholdtwin', defaultVal=0.0_pReal) prm%Cmfptwin = config_phase(p)%getFloat('cmfptwin', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%shear_twin = lattice_characteristicShear_Twin(prm%Ntwin,structure(1:3),& + config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + if (.not. prm%isFCC) then prm%Ndot0_twin = config_phase(p)%getFloats('ndot0_twin') @@ -627,13 +630,11 @@ subroutine plastic_dislotwin_init(fileUnit) allocate(prm%C66_twin(6,6,prm%totalNtwin), source=0.0_pReal) if (lattice_structure(p) == LATTICE_fcc_ID) & allocate(prm%fcc_twinNucleationSlipPair(2,prm%totalNtwin),source = 0_pInt) - allocate(prm%shear_twin(prm%totalNtwin),source = 0.0_pReal) i = 0_pInt twinFamiliesLoop: do f = 1_pInt, size(prm%Ntwin,1) index_myFamily = sum(prm%Ntwin(1:f-1_pInt)) ! index in truncated twin system list twinSystemsLoop: do j = 1_pInt,prm%Ntwin(f) i = i + 1_pInt - prm%shear_twin(i) = lattice_shearTwin(sum(lattice_Ntwinsystem(1:f-1,p))+j,p) if (lattice_structure(p) == LATTICE_fcc_ID) prm%fcc_twinNucleationSlipPair(1:2,i) = & lattice_fcc_twinNucleationSlipPair(1:2,sum(lattice_Ntwinsystem(1:f-1,p))+j) !* Rotate twin elasticity matrices @@ -644,7 +645,7 @@ subroutine plastic_dislotwin_init(fileUnit) enddo twinSystemsLoop enddo twinFamiliesLoop - + allocate(temp1(prm%totalNtrans,prm%totalNslip), source =0.0_pReal) allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) From efbd50c9318fda9ce26347d70d96baeff8998b62 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 10 Dec 2018 05:52:36 +0100 Subject: [PATCH 094/372] parameters in bold allow easy distinction --- src/lattice.f90 | 82 ++++++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 42 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 69b0de5a6..062e67977 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -73,13 +73,13 @@ module lattice LATTICE_fcc_NcleavageSystem = int([3, 4, 0],pInt) !< # of cleavage systems per family for fcc integer(pInt), parameter, private :: & - LATTICE_fcc_Nslip = sum(lattice_fcc_NslipSystem), & !< total # of slip systems for fcc - LATTICE_fcc_Ntwin = sum(lattice_fcc_NtwinSystem), & !< total # of twin systems for fcc + LATTICE_FCC_NSLIP = sum(lattice_fcc_NslipSystem), & !< total # of slip systems for fcc + LATTICE_FCC_NTWIN = sum(lattice_fcc_NtwinSystem), & !< total # of twin systems for fcc LATTICE_fcc_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for fcc LATTICE_fcc_Ntrans = sum(lattice_fcc_NtransSystem), & !< total # of transformation systems for fcc LATTICE_fcc_Ncleavage = sum(lattice_fcc_NcleavageSystem) !< total # of cleavage systems for fcc - real(pReal), dimension(3+3,LATTICE_fcc_Nslip), parameter, private :: & + real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & LATTICE_fcc_systemSlip = reshape(real([& ! Slip direction Plane normal ! SCHMID-BOAS notation 0, 1,-1, 1, 1, 1, & ! B2 @@ -107,7 +107,7 @@ module lattice ['<0 1 -1>{1 1 1}', & '<0 1 -1>{0 1 1}'] - real(pReal), dimension(3+3,LATTICE_fcc_Ntwin), parameter, private :: & + real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter, private :: & LATTICE_fcc_systemTwin = reshape(real( [& -2, 1, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, & @@ -142,11 +142,11 @@ module lattice -1, 1, 2, -1, 1,-1 & ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) - real(pReal), dimension(LATTICE_fcc_Ntwin), parameter, private :: & + real(pReal), dimension(LATTICE_FCC_NTWIN), parameter, private :: & LATTICE_fcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) !< Twin system <112>{111} ??? Sorted according to Eisenlohr & Hantcherli - integer(pInt), dimension(2_pInt,LATTICE_fcc_Ntwin), parameter, public :: & - LATTICE_fcc_twinNucleationSlipPair = reshape(int( [& + integer(pInt), dimension(2_pInt,LATTICE_FCC_NTWIN), parameter, public :: & + LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape(int( [& 2,3, & 1,3, & 1,2, & @@ -161,8 +161,8 @@ module lattice 10,11 & ],pInt),shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) - integer(pInt), dimension(LATTICE_fcc_Nslip,lattice_fcc_Nslip), parameter, public :: & - LATTICE_fcc_interactionSlipSlip = reshape(int( [& + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter, public :: & + LATTICE_FCC_INTERACTIONSLIPSLIP = reshape(int( [& 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & ! ---> slip 2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5, 9,10,11,12, 9,10, & ! | 2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & ! | @@ -182,7 +182,7 @@ module lattice 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & - ],pInt),[LATTICE_fcc_Nslip,LATTICE_fcc_Nslip],order=[2,1]) !< Slip--slip interaction types for fcc + ],pInt),shape(LATTICE_FCC_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for fcc !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction @@ -195,8 +195,8 @@ module lattice !<10: similar to glissile junctions in <110>{111} btw one {110} and one {111} plane !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - integer(pInt), dimension(LATTICE_fcc_Nslip,LATTICE_fcc_Ntwin), parameter, public :: & - LATTICE_fcc_interactionSlipTwin = reshape(int( [& + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter, public :: & + LATTICE_FCC_INTERACTIONSLIPTWIN = reshape(int( [& 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> twin 1,1,1,3,3,3,3,3,3,2,2,2, & ! | 1,1,1,2,2,2,3,3,3,3,3,3, & ! | @@ -220,11 +220,11 @@ module lattice !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction - integer(pInt), dimension(LATTICE_fcc_Ntwin,LATTICE_fcc_Nslip), parameter, public :: & + integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter, public :: & LATTICE_fcc_interactionTwinSlip = 1_pInt !< Twin--Slip interaction types for fcc - integer(pInt), dimension(LATTICE_fcc_Ntwin,LATTICE_fcc_Ntwin), parameter,public :: & - LATTICE_fcc_interactionTwinTwin = reshape(int( [& + integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter,public :: & + LATTICE_FCC_INTERACTIONTWINTWIN = reshape(int( [& 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> twin 1,1,1,2,2,2,2,2,2,2,2,2, & ! | 1,1,1,2,2,2,2,2,2,2,2,2, & ! | @@ -239,8 +239,8 @@ module lattice 2,2,2,2,2,2,2,2,2,1,1,1 & ],pInt),shape(LATTICE_FCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for fcc - integer(pInt), dimension(LATTICE_fcc_Nslip,LATTICE_fcc_Ntrans), parameter, public :: & - LATTICE_fccTohex_interactionSlipTrans = reshape(int( [& + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_fcc_Ntrans), parameter, public :: & + LATTICE_FCCTOHEX_INTERACTIONSLIPTRANS = reshape(int( [& 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> trans 1,1,1,3,3,3,3,3,3,2,2,2, & ! | 1,1,1,2,2,2,3,3,3,3,3,3, & ! | @@ -262,7 +262,7 @@ module lattice 4,4,4,4,4,4,4,4,4,4,4,4 & ],pInt),shape(LATTICE_FCCTOHEX_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc - integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Nslip), parameter, public :: & + integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_FCC_NSLIP), parameter, public :: & LATTICE_fccTohex_interactionTransSlip = 1_pInt !< Trans--Slip interaction types for fcc integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter,public :: & @@ -285,7 +285,7 @@ module lattice LATTICE_fccTohex_shearTrans = sqrt(1.0_pReal/8.0_pReal) real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_fccTobcc_systemTrans = reshape([& + LATTICE_FCCTOBCC_SYSTEMTRANS = reshape([& 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) 0.0, 1.0, 0.0, -10.26, & 0.0, 0.0, 1.0, 10.26, & @@ -301,7 +301,7 @@ module lattice ],shape(LATTICE_FCCTOBCC_SYSTEMTRANS)) integer(pInt), dimension(9,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_fccTobcc_bainVariant = reshape(int( [& + LATTICE_FCCTOBCC_BAINVARIANT = reshape(int( [& 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) 1, 0, 0, 0, 1, 0, 0, 0, 1, & 1, 0, 0, 0, 1, 0, 0, 0, 1, & @@ -317,7 +317,7 @@ module lattice ],pInt),shape(LATTICE_FCCTOBCC_BAINVARIANT)) real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_fccTobcc_bainRot = reshape([& + LATTICE_FCCTOBCC_BAINROT = reshape([& 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant 1.0, 0.0, 0.0, 45.0, & 1.0, 0.0, 0.0, 45.0, & @@ -333,7 +333,7 @@ module lattice ],shape(LATTICE_FCCTOBCC_BAINROT)) real(pReal), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter, private :: & ! Matrix for projection of shear from slip system to fault-band (twin) systems - LATTICE_fccTobcc_projectionTrans = reshape(real([& ! For ns = nt = nr + LATTICE_FCCTOBCC_PROJECTIONTRANS = reshape(real([& ! For ns = nt = nr 0, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & -1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & @@ -355,7 +355,7 @@ module lattice LATTICE_fccTobcc_shearCritTrans = 0.0224 integer(pInt), dimension(2_pInt,LATTICE_fcc_Ntrans), parameter, public :: & - LATTICE_fccTobcc_transNucleationTwinPair = reshape(int( [& + LATTICE_FCCTOBCC_TRANSNUCLEATIONTWINPAIR = reshape(int( [& 4, 7, & 1, 10, & 1, 4, & @@ -397,13 +397,13 @@ module lattice LATTICE_bcc_NcleavageSystem = int([3, 6, 0],pInt) !< # of cleavage systems per family for bcc integer(pInt), parameter, private :: & - LATTICE_bcc_Nslip = sum(lattice_bcc_NslipSystem), & !< total # of slip systems for bcc - LATTICE_bcc_Ntwin = sum(lattice_bcc_NtwinSystem), & !< total # of twin systems for bcc + LATTICE_BCC_NSLIP = sum(lattice_bcc_NslipSystem), & !< total # of slip systems for bcc + LATTICE_BCC_NTWIN = sum(lattice_bcc_NtwinSystem), & !< total # of twin systems for bcc LATTICE_bcc_NnonSchmid = 6_pInt, & !< total # of non-Schmid contributions for bcc (A. Koester, A. Ma, A. Hartmaier 2012) LATTICE_bcc_Ntrans = sum(lattice_bcc_NtransSystem), & !< total # of transformation systems for bcc LATTICE_bcc_Ncleavage = sum(lattice_bcc_NcleavageSystem) !< total # of cleavage systems for bcc - real(pReal), dimension(3+3,LATTICE_bcc_Nslip), parameter, private :: & + real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & LATTICE_bcc_systemSlip = reshape(real([& ! Slip direction Plane normal ! Slip system <111>{110} @@ -463,7 +463,7 @@ module lattice ['<1 -1 1>{0 1 1}', & '<1 -1 1>{2 1 1}'] - real(pReal), dimension(3+3,LATTICE_bcc_Ntwin), parameter, private :: & + real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter, private :: & LATTICE_bcc_systemTwin = reshape(real([& ! Twin system <111>{112} -1, 1, 1, 2, 1, 1, & @@ -483,10 +483,10 @@ module lattice character(len=*), dimension(1), parameter, public :: LATTICE_BCC_TWINFAMILY_NAME = & ['<1 1 1>{2 1 1}'] - real(pReal), dimension(LATTICE_bcc_Ntwin), parameter, private :: & + real(pReal), dimension(LATTICE_BCC_NTWIN), parameter, private :: & LATTICE_bcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) - integer(pInt), dimension(LATTICE_bcc_Nslip,LATTICE_bcc_Nslip), parameter, public :: & + integer(pInt), dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter, public :: & LATTICE_bcc_interactionSlipSlip = reshape(int( [& 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & ! ---> slip 2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & ! | @@ -520,7 +520,7 @@ module lattice !< 4: mixed-asymmetrical junction !< 5: mixed-symmetrical junction !< 6: edge junction - integer(pInt), dimension(LATTICE_bcc_Nslip,LATTICE_bcc_Ntwin), parameter, public :: & + integer(pInt), dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter, public :: & LATTICE_bcc_interactionSlipTwin = reshape(int( [& 3,3,3,2,2,3,3,3,3,2,3,3, & ! ---> twin 3,3,2,3,3,2,3,3,2,3,3,3, & ! | @@ -551,10 +551,10 @@ module lattice !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction - integer(pInt), dimension(LATTICE_bcc_Ntwin,LATTICE_bcc_Nslip), parameter, public :: & + integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter, public :: & LATTICE_bcc_interactionTwinSlip = 1_pInt !< Twin--slip interaction types for bcc @todo not implemented yet - integer(pInt), dimension(LATTICE_bcc_Ntwin,LATTICE_bcc_Ntwin), parameter, public :: & + integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter, public :: & LATTICE_bcc_interactionTwinTwin = reshape(int( [& 1,3,3,3,3,3,3,2,3,3,2,3, & ! ---> twin 3,1,3,3,3,3,2,3,3,3,3,2, & ! | @@ -1117,9 +1117,9 @@ module lattice ! BEGIN DEPRECATED integer(pInt), parameter, public :: & - LATTICE_maxNslip = max(LATTICE_fcc_Nslip,LATTICE_bcc_Nslip,LATTICE_hex_Nslip, & + LATTICE_maxNslip = max(LATTICE_FCC_NSLIP,LATTICE_BCC_NSLIP,LATTICE_hex_Nslip, & LATTICE_bct_Nslip,LATTICE_iso_Nslip,LATTICE_ortho_Nslip), & !< max # of slip systems over lattice structures - LATTICE_maxNtwin = max(LATTICE_fcc_Ntwin,LATTICE_bcc_Ntwin,LATTICE_hex_Ntwin, & + LATTICE_maxNtwin = max(LATTICE_FCC_NTWIN,LATTICE_BCC_NTWIN,LATTICE_hex_Ntwin, & LATTICE_bct_Ntwin,LATTICE_iso_Ntwin,LATTICE_ortho_Ntwin), & !< max # of twin systems over lattice structures LATTICE_maxNnonSchmid = max(LATTICE_fcc_NnonSchmid,LATTICE_bcc_NnonSchmid, & LATTICE_hex_NnonSchmid,LATTICE_bct_NnonSchmid, & @@ -1259,7 +1259,8 @@ real(pReal), dimension(4,36), parameter, private :: & lattice_interaction_SlipTwin, & lattice_interaction_TwinSlip, & lattice_interaction_TransTrans, & - lattice_characteristicShear_Twin + lattice_characteristicShear_Twin, & + lattice_C66_twin contains @@ -1602,8 +1603,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) !-------------------------------------------------------------------------------------------------- ! fcc case (LATTICE_fcc_ID) - myNslip = lattice_fcc_Nslip - myNtwin = lattice_fcc_Ntwin + myNslip = LATTICE_FCC_NSLIP + myNtwin = LATTICE_FCC_NTWIN myNtrans = lattice_fcc_Ntrans myNcleavage = lattice_fcc_Ncleavage do i = 1_pInt,myNslip ! assign slip system vectors @@ -1676,8 +1677,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) !-------------------------------------------------------------------------------------------------- ! bcc case (LATTICE_bcc_ID) - myNslip = lattice_bcc_Nslip - myNtwin = lattice_bcc_Ntwin + myNslip = LATTICE_BCC_NSLIP + myNtwin = LATTICE_BCC_NTWIN myNtrans = lattice_bcc_Ntrans myNcleavage = lattice_bcc_Ncleavage do i = 1_pInt,myNslip ! assign slip system vectors @@ -2149,7 +2150,6 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) R = math_axisAngleToR(coordinateSystem(1:3,2,i), 180.0_pReal * INRAD) ! ToDo: Why always 180 deg? lattice_C66_twin(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(math_Mandel66to3333(C66),R)) enddo - end function lattice_C66_twin @@ -2520,9 +2520,7 @@ function lattice_interaction_TransTrans(Ntrans,interactionValues,structure,targe !if (size(interactionValues) > maxval(interactionTypes)) & ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) - end function lattice_interaction_TransTrans From 51d8011afeb28748016df900746fb2d9aef39235 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 10 Dec 2018 08:33:20 +0100 Subject: [PATCH 095/372] cleaned - only define variables that are needed - define variables where they are needed --- src/lattice.f90 | 703 ++++++++++++++++++++---------------------------- 1 file changed, 298 insertions(+), 405 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 062e67977..0b99bbc45 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -16,13 +16,11 @@ module lattice ! BEGIN DEPRECATED integer(pInt), parameter, public :: & LATTICE_maxNslipFamily = 13_pInt, & !< max # of slip system families over lattice structures - LATTICE_maxNtwinFamily = 4_pInt, & !< max # of twin system families over lattice structures LATTICE_maxNtransFamily = 1_pInt, & !< max # of transformation system families over lattice structures LATTICE_maxNcleavageFamily = 3_pInt !< max # of transformation system families over lattice structures integer(pInt), allocatable, dimension(:,:), protected, public :: & lattice_NslipSystem, & !< total # of slip systems in each family - lattice_NtwinSystem, & !< total # of twin systems in each family lattice_NtransSystem, & !< total # of transformation systems in each family lattice_NcleavageSystem !< total # of transformation systems in each family @@ -31,7 +29,6 @@ module lattice lattice_interactionSlipTrans, & !< Slip--trans interaction type lattice_interactionTransSlip !< Trans--slip interaction type - real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & lattice_Sslip, & !< Schmid and non-Schmid matrices lattice_Scleavage !< Schmid matrices for cleavage systems @@ -40,14 +37,12 @@ module lattice lattice_Sslip_v, & !< Mandel notation of lattice_Sslip lattice_Scleavage_v, & !< Mandel notation of lattice_Scleavege lattice_Qtrans, & !< Total rotation: Q = R*B - lattice_Strans, & !< Eigendeformation tensor for phase transformation - lattice_Qtwin + lattice_Strans !< Eigendeformation tensor for phase transformation real(pReal), allocatable, dimension(:,:,:), protected, public :: & lattice_sn, & !< normal direction of slip system lattice_st, & !< sd x sn - lattice_sd, & !< slip direction of slip system - lattice_Strans_v !< Eigendeformation tensor in vector form + lattice_sd !< slip direction of slip system real(pReal), allocatable, dimension(:,:), protected, public :: & lattice_shearTrans !< characteristic transformation shear @@ -63,8 +58,8 @@ module lattice integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & LATTICE_fcc_NslipSystem = int([12, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for fcc - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - LATTICE_fcc_NtwinSystem = int([12, 0, 0, 0],pInt) !< # of twin systems per family for fcc + integer(pInt), dimension(1), parameter, public :: & + LATTICE_FCC_NTWINSYSTEM = int([12],pInt) !< # of twin systems per family for fcc integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & LATTICE_fcc_NtransSystem = int([12],pInt) !< # of transformation systems per family for fcc @@ -74,8 +69,7 @@ module lattice integer(pInt), parameter, private :: & LATTICE_FCC_NSLIP = sum(lattice_fcc_NslipSystem), & !< total # of slip systems for fcc - LATTICE_FCC_NTWIN = sum(lattice_fcc_NtwinSystem), & !< total # of twin systems for fcc - LATTICE_fcc_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for fcc + LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc LATTICE_fcc_Ntrans = sum(lattice_fcc_NtransSystem), & !< total # of transformation systems for fcc LATTICE_fcc_Ncleavage = sum(lattice_fcc_NcleavageSystem) !< total # of cleavage systems for fcc @@ -195,49 +189,10 @@ module lattice !<10: similar to glissile junctions in <110>{111} btw one {110} and one {111} plane !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter, public :: & - LATTICE_FCC_INTERACTIONSLIPTWIN = reshape(int( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> twin - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],pInt),shape(LATTICE_FCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for fcc - !< 1: coplanar interaction - !< 2: screw trace between slip system and twin habit plane (easy cross slip) - !< 3: other interaction - integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter, public :: & - LATTICE_fcc_interactionTwinSlip = 1_pInt !< Twin--Slip interaction types for fcc - integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter,public :: & - LATTICE_FCC_INTERACTIONTWINTWIN = reshape(int( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> twin - 1,1,1,2,2,2,2,2,2,2,2,2, & ! | - 1,1,1,2,2,2,2,2,2,2,2,2, & ! | - 2,2,2,1,1,1,2,2,2,2,2,2, & ! v twin - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],pInt),shape(LATTICE_FCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for fcc + + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_fcc_Ntrans), parameter, public :: & LATTICE_FCCTOHEX_INTERACTIONSLIPTRANS = reshape(int( [& @@ -387,20 +342,16 @@ module lattice integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & LATTICE_bcc_NslipSystem = int([ 12, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], pInt) !< # of slip systems per family for bcc - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - LATTICE_bcc_NtwinSystem = int([ 12, 0, 0, 0], pInt) !< # of twin systems per family for bcc - - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & - LATTICE_bcc_NtransSystem = int([0],pInt) !< # of transformation systems per family for bcc + integer(pInt), dimension(1), parameter, public :: & + LATTICE_BCC_NTWINSYSTEM = int([12], pInt) !< # of twin systems per family for bcc integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & LATTICE_bcc_NcleavageSystem = int([3, 6, 0],pInt) !< # of cleavage systems per family for bcc integer(pInt), parameter, private :: & LATTICE_BCC_NSLIP = sum(lattice_bcc_NslipSystem), & !< total # of slip systems for bcc - LATTICE_BCC_NTWIN = sum(lattice_bcc_NtwinSystem), & !< total # of twin systems for bcc + LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc LATTICE_bcc_NnonSchmid = 6_pInt, & !< total # of non-Schmid contributions for bcc (A. Koester, A. Ma, A. Hartmaier 2012) - LATTICE_bcc_Ntrans = sum(lattice_bcc_NtransSystem), & !< total # of transformation systems for bcc LATTICE_bcc_Ncleavage = sum(lattice_bcc_NcleavageSystem) !< total # of cleavage systems for bcc real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & @@ -520,58 +471,7 @@ module lattice !< 4: mixed-asymmetrical junction !< 5: mixed-symmetrical junction !< 6: edge junction - integer(pInt), dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter, public :: & - LATTICE_bcc_interactionSlipTwin = reshape(int( [& - 3,3,3,2,2,3,3,3,3,2,3,3, & ! ---> twin - 3,3,2,3,3,2,3,3,2,3,3,3, & ! | - 3,2,3,3,3,3,2,3,3,3,3,2, & ! | - 2,3,3,3,3,3,3,2,3,3,2,3, & ! v slip - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,2,3,3,2,3,3,2,3,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,2,3,3,2,3,3,2,3,3,3, & - ! - 1,3,3,3,3,3,3,2,3,3,2,3, & - 3,1,3,3,3,3,2,3,3,3,3,2, & - 3,3,1,3,3,2,3,3,2,3,3,3, & - 3,3,3,1,2,3,3,3,3,2,3,3, & - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),shape(LATTICE_BCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for bcc - !< 1: coplanar interaction - !< 2: screw trace between slip system and twin habit plane (easy cross slip) - !< 3: other interaction - integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter, public :: & - LATTICE_bcc_interactionTwinSlip = 1_pInt !< Twin--slip interaction types for bcc @todo not implemented yet - integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter, public :: & - LATTICE_bcc_interactionTwinTwin = reshape(int( [& - 1,3,3,3,3,3,3,2,3,3,2,3, & ! ---> twin - 3,1,3,3,3,3,2,3,3,3,3,2, & ! | - 3,3,1,3,3,2,3,3,2,3,3,3, & ! | - 3,3,3,1,2,3,3,3,3,2,3,3, & ! v twin - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),shape(LATTICE_BCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for bcc - !< 1: self interaction - !< 2: collinear interaction - !< 3: other interaction real(pReal), dimension(3+3,LATTICE_bcc_Ncleavage), parameter, private :: & LATTICE_bcc_systemCleavage = reshape(real([& ! Cleavage direction Plane normal @@ -591,20 +491,15 @@ module lattice integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & lattice_hex_NslipSystem = int([ 3, 3, 3, 6, 12, 6, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for hex - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - lattice_hex_NtwinSystem = int([ 6, 6, 6, 6],pInt) !< # of slip systems per family for hex - - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & - LATTICE_hex_NtransSystem = int([0],pInt) !< # of transformation systems per family for hex + integer(pInt), dimension(4), parameter, public :: & + LATTICE_HEX_NTWINSYSTEM = int([ 6, 6, 6, 6],pInt) !< # of slip systems per family for hex integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & LATTICE_hex_NcleavageSystem = int([3, 0, 0],pInt) !< # of cleavage systems per family for hex integer(pInt), parameter, private :: & LATTICE_hex_Nslip = sum(lattice_hex_NslipSystem), & !< total # of slip systems for hex - LATTICE_hex_Ntwin = sum(lattice_hex_NtwinSystem), & !< total # of twin systems for hex - LATTICE_hex_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for hex - LATTICE_hex_Ntrans = sum(lattice_hex_NtransSystem), & !< total # of transformation systems for hex + LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex LATTICE_hex_Ncleavage = sum(lattice_hex_NcleavageSystem) !< total # of cleavage systems for hex real(pReal), dimension(4+4,LATTICE_hex_Nslip), parameter, private :: & @@ -768,110 +663,8 @@ module lattice ! ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) - integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Ntwin), parameter, public :: & - LATTICE_hex_interactionSlipTwin = reshape(int( [& - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! --> twin - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - ! v - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - ! - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - ! - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - ! - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - ! - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & - ! - ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) - integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Nslip), parameter, public :: & - LATTICE_hex_interactionTwinSlip = reshape(int( [& - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! --> slip - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & - ! - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - ! - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - ! - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & - ],pInt),shape(LATTICE_HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) - integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Ntwin), parameter, public :: & - LATTICE_hex_interactionTwinTwin = reshape(int( [& - 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! ---> twin - 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | - 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | - 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! v twin - 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - ! - 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - ! - 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & - ! - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & - ],pInt),shape(LATTICE_HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--slip interaction types for hex (isotropic, 16 in total) real(pReal), dimension(4+4,LATTICE_hex_Ncleavage), parameter, private :: & LATTICE_hex_systemCleavage = reshape(real([& @@ -887,21 +680,8 @@ module lattice integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & LATTICE_bct_NslipSystem = int([2, 2, 2, 4, 2, 4, 2, 2, 4, 8, 4, 8, 8 ],pInt) !< # of slip systems per family for bct (Sn) Bieler J. Electr Mater 2009 - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - LATTICE_bct_NtwinSystem = int([0, 0, 0, 0], pInt) !< # of twin systems per family for bct - - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & - LATTICE_bct_NtransSystem = int([0],pInt) !< # of transformation systems per family for bct - - integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & - LATTICE_bct_NcleavageSystem = int([0, 0, 0],pInt) !< # of cleavage systems per family for bct - integer(pInt), parameter, private :: & - LATTICE_bct_Nslip = sum(lattice_bct_NslipSystem), & !< total # of slip systems for bct - LATTICE_bct_Ntwin = sum(lattice_bct_NtwinSystem), & !< total # of twin systems for bct - LATTICE_bct_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for bct - LATTICE_bct_Ntrans = sum(lattice_bct_NtransSystem), & !< total # of transformation systems for bct - LATTICE_bct_Ncleavage = sum(lattice_bct_NcleavageSystem) !< total # of cleavage systems for bct + LATTICE_bct_Nslip = sum(lattice_bct_NslipSystem) !< total # of slip systems for bct real(pReal), dimension(3+3,LATTICE_bct_Nslip), parameter, private :: & LATTICE_bct_systemSlip = reshape(real([& @@ -1059,23 +839,10 @@ module lattice !-------------------------------------------------------------------------------------------------- ! isotropic - integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & - LATTICE_iso_NslipSystem = int([0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],pInt) !< # of slip systems per family for iso - - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - LATTICE_iso_NtwinSystem = int([0, 0, 0, 0], pInt) !< # of twin systems per family for iso - - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & - LATTICE_iso_NtransSystem = int([0],pInt) !< # of transformation systems per family for iso - integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & LATTICE_iso_NcleavageSystem = int([3, 0, 0],pInt) !< # of cleavage systems per family for iso integer(pInt), parameter, private :: & - LATTICE_iso_Nslip = sum(lattice_iso_NslipSystem), & !< total # of slip systems for iso - LATTICE_iso_Ntwin = sum(lattice_iso_NtwinSystem), & !< total # of twin systems for iso - LATTICE_iso_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for iso - LATTICE_iso_Ntrans = sum(lattice_iso_NtransSystem), & !< total # of transformation systems for iso LATTICE_iso_Ncleavage = sum(lattice_iso_NcleavageSystem) !< total # of cleavage systems for iso real(pReal), dimension(3+3,LATTICE_iso_Ncleavage), parameter, private :: & @@ -1088,23 +855,10 @@ module lattice !-------------------------------------------------------------------------------------------------- ! orthorhombic - integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & - LATTICE_ortho_NslipSystem = int([0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],pInt) !< # of slip systems per family for ortho - - integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & - LATTICE_ortho_NtwinSystem = int([0, 0, 0, 0], pInt) !< # of twin systems per family for ortho - - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & - LATTICE_ortho_NtransSystem = int([0],pInt) !< # of transformation systems per family for ortho - integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & LATTICE_ortho_NcleavageSystem = int([1, 1, 1],pInt) !< # of cleavage systems per family for ortho integer(pInt), parameter, private :: & - LATTICE_ortho_Nslip = sum(lattice_ortho_NslipSystem), & !< total # of slip systems for ortho - LATTICE_ortho_Ntwin = sum(lattice_ortho_NtwinSystem), & !< total # of twin systems for ortho - LATTICE_ortho_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for ortho - LATTICE_ortho_Ntrans = sum(lattice_ortho_NtransSystem), & !< total # of transformation systems for ortho LATTICE_ortho_Ncleavage = sum(lattice_ortho_NcleavageSystem) !< total # of cleavage systems for ortho real(pReal), dimension(3+3,LATTICE_ortho_Ncleavage), parameter, private :: & @@ -1118,43 +872,14 @@ module lattice ! BEGIN DEPRECATED integer(pInt), parameter, public :: & LATTICE_maxNslip = max(LATTICE_FCC_NSLIP,LATTICE_BCC_NSLIP,LATTICE_hex_Nslip, & - LATTICE_bct_Nslip,LATTICE_iso_Nslip,LATTICE_ortho_Nslip), & !< max # of slip systems over lattice structures - LATTICE_maxNtwin = max(LATTICE_FCC_NTWIN,LATTICE_BCC_NTWIN,LATTICE_hex_Ntwin, & - LATTICE_bct_Ntwin,LATTICE_iso_Ntwin,LATTICE_ortho_Ntwin), & !< max # of twin systems over lattice structures - LATTICE_maxNnonSchmid = max(LATTICE_fcc_NnonSchmid,LATTICE_bcc_NnonSchmid, & - LATTICE_hex_NnonSchmid,LATTICE_bct_NnonSchmid, & - LATTICE_iso_NnonSchmid,LATTICE_ortho_NnonSchmid), & !< max # of non-Schmid contributions over lattice structures - LATTICE_maxNtrans = max(LATTICE_fcc_Ntrans,LATTICE_bcc_Ntrans,LATTICE_hex_Ntrans, & - LATTICE_bct_Ntrans,LATTICE_iso_Ntrans,LATTICE_ortho_Ntrans), & !< max # of transformation systems over lattice structures + LATTICE_bct_Nslip), & !< max # of slip systems over lattice structures + LATTICE_maxNnonSchmid = LATTICE_bcc_NnonSchmid, & !< max # of non-Schmid contributions over lattice structures + LATTICE_maxNtrans = LATTICE_fcc_Ntrans, & !< max # of transformation systems over lattice structures LATTICE_maxNcleavage = max(LATTICE_fcc_Ncleavage,LATTICE_bcc_Ncleavage, & - LATTICE_hex_Ncleavage,LATTICE_bct_Ncleavage, & + LATTICE_hex_Ncleavage, & LATTICE_iso_Ncleavage,LATTICE_ortho_Ncleavage), & !< max # of cleavage systems over lattice structures -#if defined(__GFORTRAN__) - ! only supported in gcc 8 LATTICE_maxNinteraction = 182_pInt -#else - LATTICE_maxNinteraction = max(& - maxval(lattice_fcc_interactionSlipSlip), & - maxval(lattice_bcc_interactionSlipSlip), & - maxval(lattice_hex_interactionSlipSlip), & - maxval(lattice_bct_interactionSlipSlip), & - ! - maxval(lattice_fcc_interactionSlipTwin), & - maxval(lattice_bcc_interactionSlipTwin), & - maxval(lattice_hex_interactionSlipTwin), & - !maxval(lattice_bct_interactionSlipTwin), & - ! - maxval(lattice_fcc_interactionTwinSlip), & - maxval(lattice_bcc_interactionTwinSlip), & - maxval(lattice_hex_interactionTwinSlip), & - !maxval(lattice_bct_interactionTwinSlip), & - ! - maxval(lattice_fcc_interactionTwinTwin), & - maxval(lattice_bcc_interactionTwinTwin), & - maxval(lattice_hex_interactionTwinTwin) & - !maxval(lattice_bct_interactionTwinTwin))) - ) !< max # of interaction types (in hardening matrix part) -#endif + !END DEPRECATED real(pReal), dimension(:,:,:), allocatable, private :: & temp66 @@ -1166,6 +891,8 @@ module lattice lattice_mu, lattice_nu real(pReal), dimension(:,:,:,:), allocatable, public, protected :: & ! with higher-order parameters (e.g. temperature-dependent) lattice_thermalExpansion33 + +! SHOULD NOT BE PART OF LATTICE BEGIN real(pReal), dimension(:,:,:), allocatable, public, protected :: & lattice_thermalConductivity33, & lattice_damageDiffusion33, & @@ -1188,6 +915,7 @@ module lattice lattice_referenceTemperature, & lattice_equilibriumVacancyConcentration, & lattice_equilibriumHydrogenConcentration +! SHOULD NOT BE PART OF LATTICE END enum, bind(c) enumerator :: LATTICE_undefined_ID, & LATTICE_iso_ID, & @@ -1200,49 +928,7 @@ module lattice integer(kind(LATTICE_undefined_ID)), dimension(:), allocatable, public, protected :: & lattice_structure, trans_lattice_structure - integer(pInt), dimension(2), parameter, private :: & - lattice_NsymOperations = [24_pInt,12_pInt] -real(pReal), dimension(4,36), parameter, private :: & - lattice_symOperations = reshape([& - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry - -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & -! - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry - -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & - 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & - ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 public :: & lattice_init, & @@ -1334,16 +1020,12 @@ subroutine lattice_init allocate(lattice_Scleavage(3,3,3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) - allocate(lattice_Qtwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) - allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(lattice_Strans_v(6,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(lattice_NslipSystem(lattice_maxNslipFamily,Nphases),source=0_pInt) - allocate(lattice_NtwinSystem(lattice_maxNtwinFamily,Nphases),source=0_pInt) allocate(lattice_NtransSystem(lattice_maxNtransFamily,Nphases),source=0_pInt) allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) @@ -1508,8 +1190,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sd, sn real(pReal), dimension(3,3,2,lattice_maxNnonSchmid,lattice_maxNslip) :: & sns - real(pReal), dimension(3,lattice_maxNtwin) :: & - td, tn real(pReal), dimension(lattice_maxNtrans) :: & trs real(pReal), dimension(3,lattice_maxNtrans) :: & @@ -1520,7 +1200,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) cd, cn, ct integer(pInt) :: & i,j, & - myNslip = 0_pInt, myNtwin = 0_pInt, myNtrans = 0_pInt, myNcleavage = 0_pInt + myNslip = 0_pInt, myNtrans = 0_pInt, myNcleavage = 0_pInt real(pReal) :: c11bar, c12bar, c13bar, c14bar, c33bar, c44bar, A, B lattice_C66(1:6,1:6,myPhase) = lattice_symmetrizeC66(lattice_structure(myPhase),& @@ -1604,16 +1284,12 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ! fcc case (LATTICE_fcc_ID) myNslip = LATTICE_FCC_NSLIP - myNtwin = LATTICE_FCC_NTWIN myNtrans = lattice_fcc_Ntrans myNcleavage = lattice_fcc_Ncleavage do i = 1_pInt,myNslip ! assign slip system vectors sd(1:3,i) = lattice_fcc_systemSlip(1:3,i) sn(1:3,i) = lattice_fcc_systemSlip(4:6,i) enddo - do i = 1_pInt,myNtwin ! assign twin system vectors and shears - tn(1:3,i) = lattice_fcc_systemTwin(4:6,i) - enddo do i = 1_pInt, myNcleavage ! assign cleavage system vectors cd(1:3,i) = lattice_fcc_systemCleavage(1:3,i)/norm2(lattice_fcc_systemCleavage(1:3,i)) cn(1:3,i) = lattice_fcc_systemCleavage(4:6,i)/norm2(lattice_fcc_systemCleavage(4:6,i)) @@ -1666,10 +1342,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) end select lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem - lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_fcc_NtwinSystem - lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_fcc_NtransSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem - lattice_NnonSchmid(myPhase) = lattice_fcc_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fccTohex_interactionSlipTrans lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fccTohex_interactionTransSlip @@ -1678,8 +1351,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ! bcc case (LATTICE_bcc_ID) myNslip = LATTICE_BCC_NSLIP - myNtwin = LATTICE_BCC_NTWIN - myNtrans = lattice_bcc_Ntrans + myNtrans = 0_pInt myNcleavage = lattice_bcc_Ncleavage do i = 1_pInt,myNslip ! assign slip system vectors sd(1:3,i) = lattice_bcc_systemSlip(1:3,i) @@ -1703,17 +1375,12 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sns(1:3,1:3,1,6,i) = math_tensorproduct33(sdU, sdU) sns(1:3,1:3,2,6,i) = math_tensorproduct33(-sdU, -sdU) enddo - do i = 1_pInt,myNtwin ! assign twin system vectors and shears - tn(1:3,i) = lattice_bcc_systemTwin(4:6,i) - enddo do i = 1_pInt, myNcleavage ! assign cleavage system vectors cd(1:3,i) = lattice_bcc_systemCleavage(1:3,i)/norm2(lattice_bcc_systemCleavage(1:3,i)) cn(1:3,i) = lattice_bcc_systemCleavage(4:6,i)/norm2(lattice_bcc_systemCleavage(4:6,i)) ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) enddo lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bcc_NslipSystem - lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_bcc_NtwinSystem - lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_bcc_NtransSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bcc_NcleavageSystem lattice_NnonSchmid(myPhase) = lattice_bcc_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bcc_interactionSlipSlip @@ -1722,8 +1389,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ! hex (including conversion from miller-bravais (a1=a2=a3=c) to miller (a, b, c) indices) case (LATTICE_hex_ID) myNslip = lattice_hex_Nslip - myNtwin = lattice_hex_Ntwin - myNtrans = lattice_hex_Ntrans + myNtrans = 0_pInt myNcleavage = lattice_hex_Ncleavage do i = 1_pInt,myNslip ! assign slip system vectors sd(1,i) = lattice_hex_systemSlip(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] @@ -1734,11 +1400,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sn(2,i) = (lattice_hex_systemSlip(5,i)+2.0_pReal*lattice_hex_systemSlip(6,i))/sqrt(3.0_pReal) sn(3,i) = lattice_hex_systemSlip(8,i)/CoverA enddo - do i = 1_pInt,myNtwin ! assign twin system vectors and shears - tn(1,i) = lattice_hex_systemTwin(5,i) - tn(2,i) = (lattice_hex_systemTwin(5,i)+2.0_pReal*lattice_hex_systemTwin(6,i))/sqrt(3.0_pReal) - tn(3,i) = lattice_hex_systemTwin(8,i)/CoverA - enddo do i = 1_pInt, myNcleavage ! cleavage system vectors cd(1,i) = lattice_hex_systemCleavage(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] cd(2,i) = (lattice_hex_systemCleavage(1,i)+2.0_pReal*lattice_hex_systemCleavage(2,i))*& @@ -1752,18 +1413,15 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) enddo lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_hex_NslipSystem - lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_hex_NtwinSystem - lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_hex_NtransSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem - lattice_NnonSchmid(myPhase) = lattice_hex_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! bct case (LATTICE_bct_ID) + myNtrans = 0_pInt myNslip = lattice_bct_Nslip - myNtwin = lattice_bct_Ntwin - myNcleavage = lattice_bct_Ncleavage + myNcleavage = 0_pInt do i = 1_pInt,myNslip ! assign slip system vectors sd(1:2,i) = lattice_bct_systemSlip(1:2,i) sd(3,i) = lattice_bct_systemSlip(3,i)*CoverA @@ -1773,17 +1431,12 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) snU = sn(1:3,i) / norm2(sn(1:3,i)) enddo lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bct_NslipSystem - lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_bct_NtwinSystem - lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_bct_NtransSystem - lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bct_NcleavageSystem - lattice_NnonSchmid(myPhase) = lattice_bct_NnonSchmid lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bct_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! orthorhombic (no crystal plasticity) case (LATTICE_ort_ID) myNslip = 0_pInt - myNtwin = 0_pInt myNtrans = 0_pInt myNcleavage = lattice_ortho_Ncleavage do i = 1_pInt, myNcleavage ! assign cleavage system vectors @@ -1797,7 +1450,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ! isotropic (no crystal plasticity) case (LATTICE_iso_ID) myNslip = 0_pInt - myNtwin = 0_pInt myNtrans = 0_pInt myNcleavage = lattice_iso_Ncleavage do i = 1_pInt, myNcleavage ! assign cleavage system vectors @@ -1832,13 +1484,9 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) if (abs(math_trace33(lattice_Sslip(1:3,1:3,1,i,myPhase))) > tol_math_check) & call IO_error(0_pInt,myPhase,i,0_pInt,ext_msg = 'dilatational slip Schmid matrix') enddo - do i = 1_pInt,myNtwin ! store twin system vectors and Schmid plus rotation matrix for my structure - lattice_Qtwin(1:3,1:3,i,myPhase) = math_axisAngleToR(tn(1:3,i),180.0_pReal*INRAD) - enddo do i = 1_pInt,myNtrans lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) lattice_Strans(1:3,1:3,i,myPhase) = Str(1:3,1:3,i) - lattice_Strans_v(1:6,i,myPhase) = math_Mandel33to6(math_symmetric33(lattice_Strans(1:3,1:3,i,myPhase))) lattice_shearTrans(i,myPhase) = trs(i) enddo do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure @@ -2014,6 +1662,50 @@ pure function lattice_qDisorientation(Q1, Q2, struct) integer(pInt) :: i,j,k,s,symmetry integer(kind(LATTICE_undefined_ID)) :: myStruct + integer(pInt), dimension(2), parameter :: & + NsymOperations = [24_pInt,12_pInt] + +real(pReal), dimension(4,36), parameter :: & + symOperations = reshape([& + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry + -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & +! + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry + -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & + 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & + ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 + !-------------------------------------------------------------------------------------------------- ! check if a structure with known symmetries is given if (present(struct)) then @@ -2040,13 +1732,13 @@ pure function lattice_qDisorientation(Q1, Q2, struct) select case(symmetry) case (1_pInt,2_pInt) - s = sum(lattice_NsymOperations(1:symmetry-1_pInt)) + s = sum(NsymOperations(1:symmetry-1_pInt)) do i = 1_pInt,2_pInt dQ = math_qConj(dQ) ! switch order of "from -- to" - do j = 1_pInt,lattice_NsymOperations(symmetry) ! run through first crystal's symmetries - dQsymA = math_qMul(lattice_symOperations(1:4,s+j),dQ) ! apply sym - do k = 1_pInt,lattice_NsymOperations(symmetry) ! run through 2nd crystal's symmetries - mis = math_qMul(dQsymA,lattice_symOperations(1:4,s+k)) ! apply sym + do j = 1_pInt,NsymOperations(symmetry) ! run through first crystal's symmetries + dQsymA = math_qMul(symOperations(1:4,s+j),dQ) ! apply sym + do k = 1_pInt,NsymOperations(symmetry) ! run through 2nd crystal's symmetries + mis = math_qMul(dQsymA,symOperations(1:4,s+k)) ! apply sym if (mis(1) < 0.0_pReal) & ! want positive angle mis = -mis if (mis(1)-lattice_qDisorientation(1) > -tol_math_check & @@ -2112,7 +1804,6 @@ end function lattice_characteristicShear_Twin !-------------------------------------------------------------------------------------------------- !> @brief Calculates rotated elasticity matrices for twinning -!> ToDo: Completely untested !-------------------------------------------------------------------------------------------------- function lattice_C66_twin(Ntwin,C66,structure,CoverA) use IO, only: & @@ -2344,7 +2035,7 @@ function lattice_interaction_SlipSlip(Nslip,interactionValues,structure) result( case('bcc') interactionTypes = LATTICE_BCC_INTERACTIONSLIPSLIP NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex','hexagonal') !ToDo: "No alias policy": long or short? + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? interactionTypes = LATTICE_HEX_INTERACTIONSLIPSLIP NslipMax = LATTICE_HEX_NSLIPSYSTEM case('bct') @@ -2379,15 +2070,80 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( integer(pInt), dimension(:), allocatable :: NtwinMax integer(pInt), dimension(:,:), allocatable :: interactionTypes + integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONTWINTWIN = reshape(int( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> twin + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v twin + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],pInt),shape(FCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for fcc + + integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONTWINTWIN = reshape(int( [& + 1,3,3,3,3,3,3,2,3,3,2,3, & ! ---> twin + 3,1,3,3,3,3,2,3,3,3,3,2, & ! | + 3,3,1,3,3,2,3,3,2,3,3,3, & ! | + 3,3,3,1,2,3,3,3,3,2,3,3, & ! v twin + 3,3,3,2,1,3,3,3,3,2,3,3, & + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],pInt),shape(BCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for bcc + !< 1: self interaction + !< 2: collinear interaction + !< 3: other interaction + integer(pInt), dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONTWINTWIN = reshape(int( [& + 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! ---> twin + 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! v twin + 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & + 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & + ! + 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + ! + 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & + ! + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & + ],pInt),shape(HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 16 in total) + select case(structure) case('fcc') - interactionTypes = LATTICE_FCC_INTERACTIONTWINTWIN + interactionTypes = FCC_INTERACTIONTWINTWIN NtwinMax = LATTICE_FCC_NTWINSYSTEM case('bcc') - interactionTypes = LATTICE_BCC_INTERACTIONTWINTWIN + interactionTypes = BCC_INTERACTIONTWINTWIN NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex','hexagonal') !ToDo: "No alias policy": long or short? - interactionTypes = LATTICE_HEX_INTERACTIONTWINTWIN + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + interactionTypes = HEX_INTERACTIONTWINTWIN NtwinMax = LATTICE_HEX_NTWINSYSTEM case default call IO_error(132_pInt,ext_msg=trim(structure)//' (twin twin interaction)') @@ -2420,17 +2176,117 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r integer(pInt), dimension(:), allocatable :: NtwinMax integer(pInt), dimension(:,:), allocatable :: interactionTypes + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONSLIPTWIN = reshape(int( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> twin + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip + 3,3,3,1,1,1,2,2,2,3,3,3, & + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],pInt),shape(FCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for fcc + !< 1: coplanar interaction + !< 2: screw trace between slip system and twin habit plane (easy cross slip) + !< 3: other interaction + integer(pInt), dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONSLIPTWIN = reshape(int( [& + 3,3,3,2,2,3,3,3,3,2,3,3, & ! ---> twin + 3,3,2,3,3,2,3,3,2,3,3,3, & ! | + 3,2,3,3,3,3,2,3,3,3,3,2, & ! | + 2,3,3,3,3,3,3,2,3,3,2,3, & ! v slip + 2,3,3,3,3,3,3,2,3,3,2,3, & + 3,3,2,3,3,2,3,3,2,3,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 2,3,3,3,3,3,3,2,3,3,2,3, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,2,3,3,2,3,3,2,3,3,3, & + ! + 1,3,3,3,3,3,3,2,3,3,2,3, & + 3,1,3,3,3,3,2,3,3,3,3,2, & + 3,3,1,3,3,2,3,3,2,3,3,3, & + 3,3,3,1,2,3,3,3,3,2,3,3, & + 3,3,3,2,1,3,3,3,3,2,3,3, & + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],pInt),shape(BCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for bcc + !< 1: coplanar interaction + !< 2: screw trace between slip system and twin habit plane (easy cross slip) + !< 3: other interaction + integer(pInt), dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONSLIPTWIN = reshape(int( [& + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! --> twin + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + ! v + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & + ! + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + ! + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + ! + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + ! + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & + ! + ],pInt),shape(HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) + + select case(structure) case('fcc') - interactionTypes = LATTICE_FCC_INTERACTIONSLIPTWIN + interactionTypes = FCC_INTERACTIONSLIPTWIN NslipMax = LATTICE_FCC_NSLIPSYSTEM NtwinMax = LATTICE_FCC_NTWINSYSTEM case('bcc') - interactionTypes = LATTICE_BCC_INTERACTIONSLIPTWIN + interactionTypes = BCC_INTERACTIONSLIPTWIN NslipMax = LATTICE_BCC_NSLIPSYSTEM NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex','hexagonal') !ToDo: "No alias policy": long or short? - interactionTypes = LATTICE_HEX_INTERACTIONSLIPTWIN + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + interactionTypes = HEX_INTERACTIONSLIPTWIN NslipMax = LATTICE_HEX_NSLIPSYSTEM NtwinMax = LATTICE_HEX_NTWINSYSTEM case default @@ -2464,17 +2320,54 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r integer(pInt), dimension(:), allocatable :: NtwinMax integer(pInt), dimension(:,:), allocatable :: interactionTypes + integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONTWINSLIP = 1_pInt !< Twin--Slip interaction types for fcc + + integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & + BCC_INTERACTIONTWINSLIP = 1_pInt !< Twin--slip interaction types for bcc + + integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Nslip), parameter :: & + HEX_INTERACTIONTWINSLIP = reshape(int( [& + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! --> slip + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & + ! + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + ! + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + ! + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & + ],pInt),shape(HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) + select case(structure) case('fcc') - interactionTypes = LATTICE_FCC_INTERACTIONTWINSLIP + interactionTypes = FCC_INTERACTIONTWINSLIP NtwinMax = LATTICE_FCC_NTWINSYSTEM NslipMax = LATTICE_FCC_NSLIPSYSTEM case('bcc') - interactionTypes = LATTICE_BCC_INTERACTIONTWINSLIP + interactionTypes = BCC_INTERACTIONTWINSLIP NtwinMax = LATTICE_BCC_NTWINSYSTEM NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex','hexagonal') !ToDo: "No alias policy": long or short? - interactionTypes = LATTICE_HEX_INTERACTIONTWINSLIP + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + interactionTypes = HEX_INTERACTIONTWINSLIP NtwinMax = LATTICE_HEX_NTWINSYSTEM NslipMax = LATTICE_HEX_NSLIPSYSTEM case default @@ -2510,10 +2403,10 @@ function lattice_interaction_TransTrans(Ntrans,interactionValues,structure,targe if (trim(structure) == 'fcc' .and. trim(targetStructure) == 'hex') then interactionTypes = lattice_fccToHex_interactionTransTrans - NtransMax = lattice_fcc_Ntrans + NtransMax = LATTICE_FCC_NTRANSSYSTEM elseif (trim(structure) == 'fcc' .and. trim(targetStructure) == 'bcc') then - interactionTypes = lattice_fccToHex_interactionTransTrans !< ToDo: The definition for bcc does not exist yet - NtransMax = lattice_fcc_Ntrans + interactionTypes = lattice_fccToHex_interactionTransTrans ! ToDo: The definition for bcc does not exist yet + NtransMax = LATTICE_FCC_NTRANSSYSTEM else call IO_error(132_pInt,ext_msg=trim(structure)//' => '//trim(targetStructure)) end if @@ -2554,7 +2447,7 @@ function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) case('bcc') NslipMax = LATTICE_BCC_NSLIPSYSTEM slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex','hexagonal') !ToDo: "No alias policy": long or short? + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? NslipMax = LATTICE_HEX_NSLIPSYSTEM slipSystems = LATTICE_HEX_SYSTEMSLIP case('bct') @@ -2684,9 +2577,9 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) do i = 1, sum(Ncleavage) - SchmidMatrix(1:3,1:3,1,i) = math_tensorproduct33(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,2,i) = math_tensorproduct33(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,3,i) = math_tensorproduct33(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,1,i) = math_tensorproduct33(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,2,i) = math_tensorproduct33(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,3,i) = math_tensorproduct33(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) enddo end function lattice_SchmidMatrix_cleavage From cee905443bd9cfbffe4180d5cde4443e2812c890 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 10 Dec 2018 08:34:24 +0100 Subject: [PATCH 096/372] cleaner and safer - use functions from lattice instead of repeating code - sanity check for twin nucleation --- src/plastic_dislotwin.f90 | 63 ++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 34 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 0913feb44..3c059856f 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -107,7 +107,7 @@ module plastic_dislotwin interaction_TransSlip, & !< coefficients for trans-slip interaction for each interaction type interaction_TransTrans !< coefficients for trans-trans interaction for each interaction type integer(pInt), dimension(:,:), allocatable :: & - fcc_twinNucleationSlipPair + fcc_twinNucleationSlipPair ! ToDo: Better name? Is also use for trans real(pReal), dimension(:,:), allocatable :: & forestProjectionEdge, & C66 @@ -124,7 +124,7 @@ module plastic_dislotwin outputID !< ID of each post result output logical :: & - isFCC !< twinning and transformation models are for fcc + fccTwinTransNucleation !< twinning and transformation models are for fcc integer(pInt) :: & totalNslip, & !< number of active slip systems for each family and instance totalNtwin, & !< number of active twin systems for each family and instance @@ -288,7 +288,6 @@ subroutine plastic_dislotwin_init(fileUnit) mse => microstructure(phase_plasticityInstance(p))) ! This data is read in already in lattice - prm%isFCC = merge(.true., .false., lattice_structure(p) == LATTICE_FCC_ID) prm%mu = lattice_mu(p) prm%nu = lattice_nu(p) prm%C66 = lattice_C66(1:6,1:6,p) @@ -301,6 +300,13 @@ subroutine plastic_dislotwin_init(fileUnit) prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then + + prm%fccTwinTransNucleation = merge(.true., .false., lattice_structure(p) == LATTICE_FCC_ID) & + .and. (prm%Nslip(1) == 12_pInt) + if(prm%fccTwinTransNucleation) & + prm%fcc_twinNucleationSlipPair = lattice_fcc_twinNucleationSlipPair + + prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & @@ -374,8 +380,10 @@ subroutine plastic_dislotwin_init(fileUnit) prm%shear_twin = lattice_characteristicShear_Twin(prm%Ntwin,structure(1:3),& config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + prm%C66_twin = lattice_C66_twin(prm%Ntwin,prm%C66,structure(1:3),& + config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) - if (.not. prm%isFCC) then + if (.not. prm%fccTwinTransNucleation) then prm%Ndot0_twin = config_phase(p)%getFloats('ndot0_twin') prm%Ndot0_twin = math_expand(prm%Ndot0_twin,prm%Ntwin) endif @@ -435,12 +443,15 @@ subroutine plastic_dislotwin_init(fileUnit) structure(1:3)) prm%interaction_TwinSlip = lattice_interaction_TwinSlip(prm%Ntwin,prm%Nslip,& config_phase(p)%getFloats('interaction_twinslip'), & - structure(1:3)) + structure(1:3)) + if (prm%fccTwinTransNucleation .and. prm%totalNtwin > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntwin is [6,6] endif if (prm%totalNslip > 0_pInt .and. prm%totalNtrans > 0_pInt) then prm%interaction_TransSlip = spread(config_phase(p)%getFloats('interaction_transslip'),2,1) prm%interaction_SlipTrans = spread(config_phase(p)%getFloats('interaction_sliptrans'),2,1) + + if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] endif @@ -583,8 +594,8 @@ subroutine plastic_dislotwin_init(fileUnit) ! allocate state arrays NipcMyPhase=count(material_phase==p) sizeDotState = int(size(['rho ','rhoDip ','accshearslip']),pInt) * prm%totalNslip & - + int(size(['twinFraction','accsheartwin']),pInt) * prm%totalNtwin & - + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans + + int(size(['twinFraction','accsheartwin']),pInt) * prm%totalNtwin & + + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & @@ -597,7 +608,9 @@ subroutine plastic_dislotwin_init(fileUnit) plasticState(p)%dotState(offset_slip+1:offset_slip+plasticState(p)%nslip,1:NipcMyPhase) plasticState(p)%accumulatedSlip => & plasticState(p)%state (offset_slip+1:offset_slip+plasticState(p)%nslip,1:NipcMyPhase) - + + +! DEPRECATED BEGIN allocate(temp1(prm%totalNslip,prm%totalNtrans),source =0.0_pReal) allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) i = 0_pInt @@ -627,25 +640,6 @@ subroutine plastic_dislotwin_init(fileUnit) enddo mySlipFamilies prm%interaction_SlipTrans = temp1; deallocate(temp1) - allocate(prm%C66_twin(6,6,prm%totalNtwin), source=0.0_pReal) - if (lattice_structure(p) == LATTICE_fcc_ID) & - allocate(prm%fcc_twinNucleationSlipPair(2,prm%totalNtwin),source = 0_pInt) - i = 0_pInt - twinFamiliesLoop: do f = 1_pInt, size(prm%Ntwin,1) - index_myFamily = sum(prm%Ntwin(1:f-1_pInt)) ! index in truncated twin system list - twinSystemsLoop: do j = 1_pInt,prm%Ntwin(f) - i = i + 1_pInt - if (lattice_structure(p) == LATTICE_fcc_ID) prm%fcc_twinNucleationSlipPair(1:2,i) = & - lattice_fcc_twinNucleationSlipPair(1:2,sum(lattice_Ntwinsystem(1:f-1,p))+j) - !* Rotate twin elasticity matrices - index_otherFamily = sum(lattice_NtwinSystem(1:f-1_pInt,p)) ! index in full lattice twin list - prm%C66_twin(1:6,1:6,index_myFamily+j) = & - math_Mandel3333to66(math_rotate_forward3333(lattice_C3333(1:3,1:3,1:3,1:3,p),& - lattice_Qtwin(1:3,1:3,index_otherFamily+j,p))) - enddo twinSystemsLoop - enddo twinFamiliesLoop - - allocate(temp1(prm%totalNtrans,prm%totalNslip), source =0.0_pReal) allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) @@ -672,7 +666,8 @@ subroutine plastic_dislotwin_init(fileUnit) enddo; enddo enddo transSystemsLoop enddo transFamiliesLoop - prm%interaction_TransSlip = temp1; deallocate(temp1) + prm%interaction_TransSlip = temp1; deallocate(temp1) +! DEPRECATED END startIndex=1_pInt endIndex=prm%totalNslip @@ -1051,7 +1046,7 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, significantTransStress: if (tau > tol_math_check) then StressRatio_s = (mse%threshold_stress_trans(i,of)/tau)**prm%s(i) - isFCCtrans: if (prm%isFCC) then + isFCCtrans: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) if (tau < mse%tau_r_trans(i,of)) then @@ -1189,7 +1184,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) significantTwinStress: if (tau > tol_math_check) then StressRatio_r = (mse%threshold_stress_twin(i,of)/tau)**prm%r(i) - isFCCtwin: if (prm%isFCC) then + isFCCtwin: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) if (tau < mse%tau_r_twin(i,of)) then @@ -1215,7 +1210,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) significantTransStress: if (tau > tol_math_check) then StressRatio_s = (mse%threshold_stress_trans(i,of)/tau)**prm%s(i) - isFCCtrans: if (prm%isFCC) then + isFCCtrans: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) if (tau < mse%tau_r_trans(i,of)) then @@ -1358,7 +1353,7 @@ pure subroutine kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin, do i = 1_pInt, prm%totalNtwin tau(i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) - isFCC: if (prm%isFCC) then + isFCC: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) if (tau(i) < mse%tau_r_twin(i,of)) then @@ -1430,7 +1425,7 @@ pure subroutine kinetics_trans(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_tran do i = 1_pInt, prm%totalNtrans tau(i) = math_mul33xx33(Mp,prm%Schmid_trans(1:3,1:3,i)) - isFCC: if (prm%isFCC) then + isFCC: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) if (tau(i) < mse%tau_r_trans(i,of)) then @@ -1605,7 +1600,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe tau = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) if ( tau > 0.0_pReal ) then - isFCCtwin: if (prm%isFCC) then + isFCCtwin: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,j) s2=prm%fcc_twinNucleationSlipPair(2,j) if (tau < mse%tau_r_twin(j,of)) then From 2fac481a267f2b9cba82e3a493e3ab26f6138c0f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 00:39:50 +0100 Subject: [PATCH 097/372] polishing/sorting --- src/lattice.f90 | 374 ++++++++++++++++++++++++-------------- src/plastic_dislotwin.f90 | 3 +- 2 files changed, 242 insertions(+), 135 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 0b99bbc45..8e282b718 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -136,8 +136,6 @@ module lattice -1, 1, 2, -1, 1,-1 & ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) - real(pReal), dimension(LATTICE_FCC_NTWIN), parameter, private :: & - LATTICE_fcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) !< Twin system <112>{111} ??? Sorted according to Eisenlohr & Hantcherli integer(pInt), dimension(2_pInt,LATTICE_FCC_NTWIN), parameter, public :: & LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape(int( [& @@ -195,7 +193,7 @@ module lattice integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_fcc_Ntrans), parameter, public :: & - LATTICE_FCCTOHEX_INTERACTIONSLIPTRANS = reshape(int( [& + LATTICE_FCC_INTERACTIONSLIPTRANS = reshape(int( [& 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> trans 1,1,1,3,3,3,3,3,3,2,2,2, & ! | 1,1,1,2,2,2,3,3,3,3,3,3, & ! | @@ -215,26 +213,10 @@ module lattice 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4 & - ],pInt),shape(LATTICE_FCCTOHEX_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc + ],pInt),shape(LATTICE_FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_FCC_NSLIP), parameter, public :: & - LATTICE_fccTohex_interactionTransSlip = 1_pInt !< Trans--Slip interaction types for fcc - - integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter,public :: & - LATTICE_fccTohex_interactionTransTrans = reshape(int( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> trans - 1,1,1,2,2,2,2,2,2,2,2,2, & ! | - 1,1,1,2,2,2,2,2,2,2,2,2, & ! | - 2,2,2,1,1,1,2,2,2,2,2,2, & ! v trans - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],pInt),shape(LATTICE_FCCTOHEX_INTERACTIONTRANSTRANS),order=[2,1]) !< Trans--trans interaction types for fcc + LATTICE_FCC_interactionTransSlip = 1_pInt !< Trans--Slip interaction types for fcc real(pReal), dimension(LATTICE_fcc_Ntrans), parameter, private :: & LATTICE_fccTohex_shearTrans = sqrt(1.0_pReal/8.0_pReal) @@ -434,8 +416,7 @@ module lattice character(len=*), dimension(1), parameter, public :: LATTICE_BCC_TWINFAMILY_NAME = & ['<1 1 1>{2 1 1}'] - real(pReal), dimension(LATTICE_BCC_NTWIN), parameter, private :: & - LATTICE_bcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) + integer(pInt), dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter, public :: & LATTICE_bcc_interactionSlipSlip = reshape(int( [& @@ -592,33 +573,6 @@ module lattice '<1 0 . -2>{1 0 . 1} ', & '<1 1 . -3>{1 1 . 2} '] - integer(pInt), dimension(LATTICE_hex_Ntwin), parameter, private :: & - LATTICE_hex_shearTwin = reshape(int( [& ! indicator to formula further below - 1, & ! <-10.1>{10.2} - 1, & - 1, & - 1, & - 1, & - 1, & - 2, & ! <11.6>{-1-1.1} - 2, & - 2, & - 2, & - 2, & - 2, & - 3, & ! <10.-2>{10.1} - 3, & - 3, & - 3, & - 3, & - 3, & - 4, & ! <11.-3>{11.2} - 4, & - 4, & - 4, & - 4, & - 4 & - ],pInt),[LATTICE_hex_Ntwin]) integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Nslip), parameter, public :: & LATTICE_hex_interactionSlipSlip = reshape(int( [& @@ -889,10 +843,10 @@ module lattice lattice_C3333, lattice_trans_C3333 real(pReal), dimension(:), allocatable, public, protected :: & lattice_mu, lattice_nu + +! SHOULD NOT BE PART OF LATTICE BEGIN real(pReal), dimension(:,:,:,:), allocatable, public, protected :: & ! with higher-order parameters (e.g. temperature-dependent) lattice_thermalExpansion33 - -! SHOULD NOT BE PART OF LATTICE BEGIN real(pReal), dimension(:,:,:), allocatable, public, protected :: & lattice_thermalConductivity33, & lattice_damageDiffusion33, & @@ -916,6 +870,7 @@ module lattice lattice_equilibriumVacancyConcentration, & lattice_equilibriumHydrogenConcentration ! SHOULD NOT BE PART OF LATTICE END + enum, bind(c) enumerator :: LATTICE_undefined_ID, & LATTICE_iso_ID, & @@ -929,7 +884,6 @@ module lattice lattice_structure, trans_lattice_structure - public :: & lattice_init, & lattice_qDisorientation, & @@ -942,9 +896,11 @@ module lattice lattice_nonSchmidMatrix, & lattice_interaction_SlipSlip, & lattice_interaction_TwinTwin, & - lattice_interaction_SlipTwin, & - lattice_interaction_TwinSlip, & lattice_interaction_TransTrans, & + lattice_interaction_SlipTwin, & + lattice_interaction_SlipTrans, & + lattice_interaction_TwinSlip, & + lattice_interaction_TransSlip, & lattice_characteristicShear_Twin, & lattice_C66_twin @@ -1149,6 +1105,84 @@ subroutine lattice_init end subroutine lattice_init +!-------------------------------------------------------------------------------------------------- +!> @brief xxx +!-------------------------------------------------------------------------------------------------- +subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) + use math, only: & + math_crossproduct, & + math_tensorproduct33, & + math_mul33x33, & + math_mul33x3, & + math_axisAngleToR, & + INRAD, & + MATH_I3 + use IO, only: & + IO_error + + implicit none + integer(pInt), dimension(:), intent(in) :: & + Ntrans + real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & + S, Q + real(pReal), intent(in), optional :: & + cOverA, & + a_fcc, & + a_bcc + + real(pReal), dimension(3,3) :: & + R, & + U, & ! Bain deformation + B, & + ss, sd + real(pReal), dimension(3) :: & + x, y, z + integer(pInt) :: & + i + + + if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' + + + if (present(a_fcc) .and. present(a_bcc)) then ! fcc -> bcc transformation + if ( a_fcc <= 0.0_pReal .or. a_bcc <= 0.0_pReal) print*, 'mist' + do i = 1_pInt,sum(Ntrans) + R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation + lattice_fccTobcc_systemTrans(4,i)*INRAD) + B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system + lattice_fccTobcc_bainRot(4,i)*INRAD) + x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) + y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) + z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) + + U = (a_bcc/a_fcc)*math_tensorproduct33(x,x) & + + (a_bcc/a_fcc)*math_tensorproduct33(y,y) * sqrt(2.0_pReal) & + + (a_bcc/a_fcc)*math_tensorproduct33(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 + enddo + elseif (present(cOverA)) then + ss = MATH_I3 + sd = MATH_I3 + ss(1,3) = sqrt(2.0_pReal)/4.0_pReal + if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & + sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) + + do i = 1_pInt,sum(Ntrans) + x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) + z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) + y = -math_crossproduct(x,z) + 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 + enddo + endif + + +end subroutine lattice_Trans + + !-------------------------------------------------------------------------------------------------- !> @brief Calculation of Schmid matrices, etc. !-------------------------------------------------------------------------------------------------- @@ -1160,7 +1194,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) math_tensorproduct33, & math_mul33x33, & math_mul33x3, & - math_transpose33, & math_trace33, & math_symmetric33, & math_Mandel33to6, & @@ -1332,7 +1365,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) Rtr(1:3,2,i) = ytr(1:3,i) Rtr(1:3,3,i) = ztr(1:3,i) Qtr(1:3,1:3,i) = Rtr(1:3,1:3,i) - Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), math_mul33x33(sttr, math_transpose33(Rtr(1:3,1:3,i)))) + Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), math_mul33x33(sttr, transpose(Rtr(1:3,1:3,i)))) Str(1:3,1:3,i) = Str(1:3,1:3,i) - MATH_I3 trs(i) = lattice_fccTohex_shearTrans(i) enddo @@ -1344,8 +1377,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip - lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fccTohex_interactionSlipTrans - lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fccTohex_interactionTransSlip + lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fcc_interactionSlipTrans + lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fcc_interactionTransSlip !-------------------------------------------------------------------------------------------------- ! bcc @@ -1770,22 +1803,55 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact mf, & !< index of my family ms !< index of my system in current family + real(pReal), dimension(LATTICE_FCC_NTWIN), parameter :: & + FCC_SHEARTWIN = 0.5_pReal*sqrt(2.0_pReal) + + real(pReal), dimension(LATTICE_BCC_NTWIN), parameter :: & + BCC_SHEARTWIN = 0.5_pReal*sqrt(2.0_pReal) + + integer(pInt), dimension(LATTICE_HEX_NTWIN), parameter :: & + HEX_SHEARTWIN = reshape(int( [& + 1, & ! <-10.1>{10.2} + 1, & + 1, & + 1, & + 1, & + 1, & + 2, & ! <11.6>{-1-1.1} + 2, & + 2, & + 2, & + 2, & + 2, & + 3, & ! <10.-2>{10.1} + 3, & + 3, & + 3, & + 3, & + 3, & + 4, & ! <11.-3>{11.2} + 4, & + 4, & + 4, & + 4, & + 4 & + ],pInt),[LATTICE_HEX_NTWIN]) ! indicator to formula further below + ir = 0_pInt myFamilies: do mf = 1_pInt,size(Ntwin,1) mySystems: do ms = 1_pInt,Ntwin(mf) ir = ir + 1_pInt - ig = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms select case(structure) case('fcc') ig = sum(LATTICE_FCC_NTWINSYSTEM(1:mf-1))+ms - characteristicShear(ir) = LATTICE_FCC_SHEARTWIN(ig) + characteristicShear(ir) = FCC_SHEARTWIN(ig) case('bcc') ig = sum(LATTICE_BCC_NTWINSYSTEM(1:mf-1))+ms - characteristicShear(ir) = LATTICE_BCC_SHEARTWIN(ig) + characteristicShear(ir) = BCC_SHEARTWIN(ig) case('hex') if (.not. present(CoverA)) call IO_error(0_pInt) ig = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms - select case(LATTICE_HEX_SHEARTWIN(ig)) ! from Christian & Mahajan 1995 p.29 + select case(HEX_SHEARTWIN(ig)) ! from Christian & Mahajan 1995 p.29 case (1_pInt) ! <-10.1>{10.2} characteristicShear(ir) = (3.0_pReal-cOverA*cOverA)/sqrt(3.0_pReal)/CoverA case (2_pInt) ! <11.6>{-1-1.1} @@ -1874,8 +1940,7 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - real(pReal), dimension(3,3) :: R,B,U,Q,S,ss,sd,st - real(pReal), dimension(3) :: x,y,z + real(pReal), dimension(3,3) :: Q,S real(pReal) :: a_bcc, a_fcc, CoverA_trans integer(pInt) :: i @@ -1909,47 +1974,6 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & call IO_error(135_pInt,el=i,ext_msg='matrix diagonal "el"ement in transformation') enddo - if (trim(structure_parent) == 'fcc' .and. trim(structure_target) == 'hex') then - do i = 1_pInt,sum(Ntrans)!!!!!!!!!!!!!! ToDo: NEED TO BE FIXED - R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation - lattice_fccTobcc_systemTrans(4,i)*INRAD) - B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system - lattice_fccTobcc_bainRot(4,i)*INRAD) - x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) - y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) - - BainDeformation: if ((a_fcc > 0.0_pReal) .and. (a_bcc > 0.0_pReal)) then - U = (a_bcc/a_fcc)*math_tensorproduct33(x,x) + & - (a_bcc/a_fcc)*math_tensorproduct33(y,y) * sqrt(2.0_pReal) + & - (a_bcc/a_fcc)*math_tensorproduct33(z,z) * sqrt(2.0_pReal) - else BainDeformation - U = 0.0_pReal - endif BainDeformation - Q = math_mul33x33(R,B) - S = math_mul33x33(R,U) - MATH_I3 - enddo - elseif (trim(structure_target) == 'bcc') then - ss = MATH_I3 - ss(1,3) = sqrt(0.125_pReal) - sd = MATH_I3 - if (CoverA_trans > 1.0_pReal .and. CoverA_trans < 2.0_pReal) then - sd(3,3) = CoverA_trans/sqrt(8.0_pReal/3.0_pReal) - endif - st = math_mul33x33(sd,ss) - do i = 1_pInt,sum(Ntrans)!!!!!!!!!!!!!! NEED TO BE FIXED - R(1:3,1) = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) - R(1:3,3) = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) - R(1:3,2) = -math_crossproduct(R(1:3,1),R(1:3,3)) - Q = R - S = math_mul33x33(R, math_mul33x33(st, transpose(R))) - MATH_I3 - ! trs(i) = lattice_fccTohex_shearTrans(i) - enddo - else - write(6,*) "Mist" - endif - - do i = 1, sum(Ntrans) ! R = math_axisAngleToR(coordinateSystem(1:3,2,i), 180.0_pReal * INRAD) ! ToDo: Why always 180 deg? ! lattice_C66_trans(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(math_Mandel66to3333(C66),R)) @@ -2157,6 +2181,53 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( end function lattice_interaction_TwinTwin +!-------------------------------------------------------------------------------------------------- +!> @brief Populates trans-trans interaction matrix +!> details: only active transformation systems are considered +!-------------------------------------------------------------------------------------------------- +function lattice_interaction_TransTrans(Ntrans,interactionValues,structure) result(interactionMatrix) + use IO, only: & + IO_error + + implicit none + integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin + character(len=*), intent(in) :: & + structure !< lattice structure of parent crystal + real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix + + integer(pInt), dimension(:), allocatable :: NtransMax + integer(pInt), dimension(:,:), allocatable :: interactionTypes + + integer(pInt), dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NTRANS), parameter :: & + FCC_INTERACTIONTRANSTRANS = reshape(int( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> trans + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v trans + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],pInt),shape(FCC_INTERACTIONTRANSTRANS),order=[2,1]) !< Trans--trans interaction types for fcc + + if (trim(structure) == 'fcc') then + interactionTypes = FCC_INTERACTIONTRANSTRANS + NtransMax = LATTICE_FCC_NTRANSSYSTEM + else + call IO_error(132_pInt,ext_msg=trim(structure)//' (trans trans interaction)') + end if + + !if (size(interactionValues) > maxval(interactionTypes)) & + ! call IO_error(0_pInt) ! ToDo + interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) +end function lattice_interaction_TransTrans + + !-------------------------------------------------------------------------------------------------- !> @brief Populates slip-twin interaction matrix !> details: only active slip and twin systems are considered @@ -2166,14 +2237,14 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + integer(pInt), dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntwin !< number of active twin systems per family real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix - integer(pInt), dimension(:), allocatable :: NslipMax - integer(pInt), dimension(:), allocatable :: NtwinMax + integer(pInt), dimension(:), allocatable :: NslipMax, & + NtwinMax integer(pInt), dimension(:,:), allocatable :: interactionTypes integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & @@ -2301,6 +2372,42 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r end function lattice_interaction_SlipTwin +!-------------------------------------------------------------------------------------------------- +!> @brief Populates trans-trans interaction matrix +!> details: only active transformation systems are considered +!-------------------------------------------------------------------------------------------------- +function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) result(interactionMatrix) + use IO, only: & + IO_error + + implicit none + integer(pInt), dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values slip--trans + character(len=*), intent(in) :: & + structure !< lattice structure of parent crystal + real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix + + integer(pInt), dimension(:), allocatable :: NslipMax, & + NtransMax + integer(pInt), dimension(:,:), allocatable :: interactionTypes + + select case(structure) + case('fcc') + interactionTypes = LATTICE_FCC_INTERACTIONSLIPTRANS + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtransMax = LATTICE_FCC_NTRANSSYSTEM + case default + call IO_error(132_pInt,ext_msg=trim(structure)//' (twin slip interaction)') + end select + + !if (size(interactionValues) > maxval(interactionTypes)) & + ! call IO_error(0_pInt) ! ToDo + interactionMatrix = buildInteraction(Nslip,Ntrans,NslipMax,NtransMax,interactionValues,interactionTypes) + +end function lattice_interaction_SlipTrans + + !-------------------------------------------------------------------------------------------------- !> @brief Populates twin-slip interaction matrix !> details: only active twin and slip systems are considered @@ -2310,14 +2417,14 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + integer(pInt), dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family + Nslip !< number of active slip systems per family real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix - integer(pInt), dimension(:), allocatable :: NslipMax - integer(pInt), dimension(:), allocatable :: NtwinMax + integer(pInt), dimension(:), allocatable :: NtwinMax, & + NslipMax integer(pInt), dimension(:,:), allocatable :: interactionTypes integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & @@ -2326,7 +2433,7 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & BCC_INTERACTIONTWINSLIP = 1_pInt !< Twin--slip interaction types for bcc - integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Nslip), parameter :: & + integer(pInt), dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & HEX_INTERACTIONTWINSLIP = reshape(int( [& 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! --> slip 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | @@ -2386,35 +2493,36 @@ end function lattice_interaction_TwinSlip !> @brief Populates trans-trans interaction matrix !> details: only active transformation systems are considered !-------------------------------------------------------------------------------------------------- -function lattice_interaction_TransTrans(Ntrans,interactionValues,structure,targetStructure) result(interactionMatrix) +function lattice_interaction_TransSlip(Ntrans,Nslip,interactionValues,structure) result(interactionMatrix) use IO, only: & IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin + integer(pInt), dimension(:), intent(in) :: Ntrans, & !< number of active trans systems per family + Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values trans-trans character(len=*), intent(in) :: & - structure, & !< lattice structure of parent crystal - targetStructure !< lattice structure of transformed crystal - real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix + structure !< lattice structure of parent crystal + real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix - integer(pInt), dimension(:), allocatable :: NtransMax + integer(pInt), dimension(:), allocatable :: NtransMax, & + NslipMax integer(pInt), dimension(:,:), allocatable :: interactionTypes - if (trim(structure) == 'fcc' .and. trim(targetStructure) == 'hex') then - interactionTypes = lattice_fccToHex_interactionTransTrans - NtransMax = LATTICE_FCC_NTRANSSYSTEM - elseif (trim(structure) == 'fcc' .and. trim(targetStructure) == 'bcc') then - interactionTypes = lattice_fccToHex_interactionTransTrans ! ToDo: The definition for bcc does not exist yet - NtransMax = LATTICE_FCC_NTRANSSYSTEM - else - call IO_error(132_pInt,ext_msg=trim(structure)//' => '//trim(targetStructure)) - end if + select case(structure) + case('fcc') + interactionTypes = LATTICE_FCC_INTERACTIONTRANSSLIP + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtransMax = LATTICE_FCC_NTRANSSYSTEM + case default + call IO_error(132_pInt,ext_msg=trim(structure)//' (twin slip interaction)') + end select !if (size(interactionValues) > maxval(interactionTypes)) & ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) -end function lattice_interaction_TransTrans + interactionMatrix = buildInteraction(Ntrans,Nslip,NtransMax,NslipMax,interactionValues,interactionTypes) + +end function lattice_interaction_TransSlip !-------------------------------------------------------------------------------------------------- diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 3c059856f..421701893 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -416,8 +416,7 @@ subroutine plastic_dislotwin_init(fileUnit) prm%interaction_TransTrans = lattice_interaction_TransTrans(prm%Ntrans,& config_phase(p)%getFloats('interaction_transtrans'), & - structure(1:3),& - trim(config_phase(p)%getString('trans_lattice_structure'))) + structure(1:3)) if (lattice_structure(p) /= LATTICE_fcc_ID) then prm%Ndot0_trans = config_phase(p)%getFloats('ndot0_trans') prm%Ndot0_trans = math_expand(prm%Ndot0_trans,prm%Ntrans) From ee60ce0d98a658d4e6ede1892251fe0de5d94b84 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 01:35:36 +0100 Subject: [PATCH 098/372] further simplifications --- src/lattice.f90 | 6 ++-- src/plastic_dislotwin.f90 | 71 +++++++++------------------------------ 2 files changed, 18 insertions(+), 59 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 8e282b718..6a2bbba10 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -2398,7 +2398,7 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) NslipMax = LATTICE_FCC_NSLIPSYSTEM NtransMax = LATTICE_FCC_NTRANSSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (twin slip interaction)') + call IO_error(132_pInt,ext_msg=trim(structure)//' (slip trans interaction)') end select !if (size(interactionValues) > maxval(interactionTypes)) & @@ -2503,7 +2503,7 @@ function lattice_interaction_TransSlip(Ntrans,Nslip,interactionValues,structure) real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values trans-trans character(len=*), intent(in) :: & structure !< lattice structure of parent crystal - real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix + real(pReal), dimension(sum(Ntrans),sum(Nslip)) :: interactionMatrix integer(pInt), dimension(:), allocatable :: NtransMax, & NslipMax @@ -2515,7 +2515,7 @@ function lattice_interaction_TransSlip(Ntrans,Nslip,interactionValues,structure) NslipMax = LATTICE_FCC_NSLIPSYSTEM NtransMax = LATTICE_FCC_NTRANSSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (twin slip interaction)') + call IO_error(132_pInt,ext_msg=trim(structure)//' (trans slip interaction)') end select !if (size(interactionValues) > maxval(interactionTypes)) & diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 421701893..dd150f3cb 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -446,9 +446,13 @@ subroutine plastic_dislotwin_init(fileUnit) if (prm%fccTwinTransNucleation .and. prm%totalNtwin > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntwin is [6,6] endif - if (prm%totalNslip > 0_pInt .and. prm%totalNtrans > 0_pInt) then - prm%interaction_TransSlip = spread(config_phase(p)%getFloats('interaction_transslip'),2,1) - prm%interaction_SlipTrans = spread(config_phase(p)%getFloats('interaction_sliptrans'),2,1) + if (prm%totalNslip > 0_pInt .and. prm%totalNtrans > 0_pInt) then + prm%interaction_SlipTrans = lattice_interaction_SlipTrans(prm%Nslip,prm%Ntrans,& + config_phase(p)%getFloats('interaction_sliptrans'), & + structure(1:3)) + prm%interaction_TransSlip = lattice_interaction_TransSlip(prm%Ntrans,prm%Nslip,& + config_phase(p)%getFloats('interaction_transslip'), & + structure(1:3)) if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] endif @@ -615,7 +619,6 @@ subroutine plastic_dislotwin_init(fileUnit) i = 0_pInt mySlipFamilies: do f = 1_pInt,size(prm%Nslip,1) index_myFamily = sum(prm%Nslip(1:f-1_pInt)) - slipSystemsLoop: do j = 1_pInt,prm%Nslip(f) i = i + 1_pInt do o = 1_pInt, size(prm%Nslip,1) @@ -625,21 +628,9 @@ subroutine plastic_dislotwin_init(fileUnit) abs(math_mul3x3(lattice_sn(:,sum(lattice_NslipSystem(1:f-1,p))+j,p), & lattice_st(:,sum(lattice_NslipSystem(1:o-1,p))+k,p))) enddo; enddo - do o = 1_pInt,size(prm%Ntrans,1) - index_otherFamily = sum(prm%Ntrans(1:o-1_pInt)) - do k = 1_pInt,prm%Ntrans(o) ! loop over (active) systems in other family (trans) - temp1(index_myFamily+j,index_otherFamily+k) = & - prm%interaction_SlipTrans(lattice_interactionSlipTrans( & - sum(lattice_NslipSystem(1:f-1_pInt,p))+j, & - sum(lattice_NtransSystem(1:o-1_pInt,p))+k, & - p),1 ) - enddo; enddo - enddo slipSystemsLoop - enddo mySlipFamilies - prm%interaction_SlipTrans = temp1; deallocate(temp1) + enddo mySlipFamilies - allocate(temp1(prm%totalNtrans,prm%totalNslip), source =0.0_pReal) allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) i = 0_pInt @@ -653,19 +644,8 @@ subroutine plastic_dislotwin_init(fileUnit) prm%C66_trans(1:6,1:6,index_myFamily+j) = & math_Mandel3333to66(math_rotate_forward3333(lattice_trans_C3333(1:3,1:3,1:3,1:3,p),& lattice_Qtrans(1:3,1:3,index_otherFamily+j,p))) - !* Interaction matrices - do o = 1_pInt,size(prm%Nslip,1) - index_otherFamily = sum(prm%Nslip(1:o-1_pInt)) - do k = 1_pInt,prm%Nslip(o) ! loop over (active) systems in other family (slip) - temp1(index_myFamily+j,index_otherFamily+k) = & - prm%interaction_TransSlip(lattice_interactionTransSlip( & - sum(lattice_NtransSystem(1:f-1_pInt,p))+j, & - sum(lattice_NslipSystem(1:o-1_pInt,p))+k, & - p) ,1 ) - enddo; enddo enddo transSystemsLoop enddo transFamiliesLoop - prm%interaction_TransSlip = temp1; deallocate(temp1) ! DEPRECATED END startIndex=1_pInt @@ -715,11 +695,11 @@ subroutine plastic_dislotwin_init(fileUnit) plasticState(p)%state0 = plasticState(p)%state dot%whole => plasticState(p)%dotState - allocate(mse%invLambdaSlip(prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTwin(prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTwin(prm%totalNtwin,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTrans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTrans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlip (prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlipTwin (prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlipTrans(prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaTwin (prm%totalNtwin,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(mse%mfp_slip(prm%totalNslip,NipcMyPhase), source=0.0_pReal) allocate(mse%mfp_twin(prm%totalNtwin,NipcMyPhase), source=0.0_pReal) @@ -756,8 +736,6 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element - type(tParameters) :: prm - type(tDislotwinState) :: stt integer(pInt) :: i, & of @@ -814,10 +792,6 @@ subroutine plastic_dislotwin_microstructure(temperature,ipc,ip,el) x0, & fOverStacksize, & ftransOverLamellarSize - - type(tParameters) :: prm !< parameters of present instance - type(tDislotwinState) :: stt !< state of present instance - type(tDislotwinMicrostructure) :: mse of = phasememberAt(ipc,ip,el) @@ -858,7 +832,7 @@ subroutine plastic_dislotwin_microstructure(temperature,ipc,ip,el) !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation if (prm%totalNtrans > 0_pInt .and. prm%totalNslip > 0_pInt) & - mse%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & + mse%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & ! ToDo: does not work if Ntrans is not 12 matmul(prm%interaction_SlipTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) @@ -930,10 +904,6 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, math_symmetric33, & math_mul33xx33, & math_mul33x3 - use material, only: & - material_phase, & - phase_plasticityInstance, & - phasememberAt implicit none real(pReal), dimension(3,3), intent(out) :: Lp @@ -975,9 +945,6 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, 0, 1,-1, & 0, 1, 1 & ],pReal),[ 3,6]) - - type(tParameters) :: prm !< parameters of present instance - type(tDislotwinState) :: ste !< state of present instance associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) @@ -1089,10 +1056,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) math_Mandel6to33, & pi use material, only: & - material_phase, & - phase_plasticityInstance, & - plasticState, & - phasememberAt + plasticState implicit none real(pReal), dimension(3,3), intent(in):: & @@ -1477,11 +1441,6 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe PI, & math_mul33xx33, & math_Mandel6to33 - use material, only: & - material_phase, & - plasticState, & - phase_plasticityInstance,& - phasememberAt implicit none real(pReal), dimension(3,3),intent(in) :: & From 1bcf41100dd839bd00d77dcaa4baafded77bb2bc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 01:47:13 +0100 Subject: [PATCH 099/372] [skip ci] WIP: cleaning contains a few bugs --- src/constitutive.f90 | 2 +- src/lattice.f90 | 120 ++++++++++---------------------------- src/plastic_dislotwin.f90 | 47 +++++---------- 3 files changed, 49 insertions(+), 120 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index eca8af08a..d7be5daac 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -163,7 +163,7 @@ subroutine constitutive_init() if (any(phase_plasticity == PLASTICITY_ISOTROPIC_ID)) call plastic_isotropic_init if (any(phase_plasticity == PLASTICITY_PHENOPOWERLAW_ID)) call plastic_phenopowerlaw_init if (any(phase_plasticity == PLASTICITY_KINEHARDENING_ID)) call plastic_kinehardening_init(FILEUNIT) - if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init if (any(phase_plasticity == PLASTICITY_DISLOUCLA_ID)) call plastic_disloucla_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) then call plastic_nonlocal_init(FILEUNIT) diff --git a/src/lattice.f90 b/src/lattice.f90 index 6a2bbba10..6598c1dc1 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -16,18 +16,14 @@ module lattice ! BEGIN DEPRECATED integer(pInt), parameter, public :: & LATTICE_maxNslipFamily = 13_pInt, & !< max # of slip system families over lattice structures - LATTICE_maxNtransFamily = 1_pInt, & !< max # of transformation system families over lattice structures LATTICE_maxNcleavageFamily = 3_pInt !< max # of transformation system families over lattice structures integer(pInt), allocatable, dimension(:,:), protected, public :: & lattice_NslipSystem, & !< total # of slip systems in each family - lattice_NtransSystem, & !< total # of transformation systems in each family lattice_NcleavageSystem !< total # of transformation systems in each family integer(pInt), allocatable, dimension(:,:,:), protected, public :: & - lattice_interactionSlipSlip, & !< Slip--slip interaction type - lattice_interactionSlipTrans, & !< Slip--trans interaction type - lattice_interactionTransSlip !< Trans--slip interaction type + lattice_interactionSlipSlip !< Slip--slip interaction type real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & lattice_Sslip, & !< Schmid and non-Schmid matrices @@ -49,7 +45,6 @@ module lattice integer(pInt), allocatable, dimension(:), protected, public :: & lattice_NnonSchmid !< total # of non-Schmid contributions for each structure - ! END DEPRECATED @@ -61,7 +56,7 @@ module lattice integer(pInt), dimension(1), parameter, public :: & LATTICE_FCC_NTWINSYSTEM = int([12],pInt) !< # of twin systems per family for fcc - integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & + integer(pInt), dimension(1), parameter, public :: & LATTICE_fcc_NtransSystem = int([12],pInt) !< # of transformation systems per family for fcc integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & @@ -188,36 +183,6 @@ module lattice !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - - - - - integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_fcc_Ntrans), parameter, public :: & - LATTICE_FCC_INTERACTIONSLIPTRANS = reshape(int( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> trans - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],pInt),shape(LATTICE_FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc - - integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_FCC_NSLIP), parameter, public :: & - LATTICE_FCC_interactionTransSlip = 1_pInt !< Trans--Slip interaction types for fcc - real(pReal), dimension(LATTICE_fcc_Ntrans), parameter, private :: & LATTICE_fccTohex_shearTrans = sqrt(1.0_pReal/8.0_pReal) @@ -900,7 +865,6 @@ module lattice lattice_interaction_SlipTwin, & lattice_interaction_SlipTrans, & lattice_interaction_TwinSlip, & - lattice_interaction_TransSlip, & lattice_characteristicShear_Twin, & lattice_C66_twin @@ -973,21 +937,16 @@ subroutine lattice_init allocate(lattice_NnonSchmid(Nphases), source=0_pInt) allocate(lattice_Sslip(3,3,1+2*lattice_maxNnonSchmid,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_Sslip_v(6,1+2*lattice_maxNnonSchmid,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_NslipSystem(lattice_maxNslipFamily,Nphases),source=0_pInt) + allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,Nphases),source=0_pInt) ! other:me + allocate(lattice_Scleavage(3,3,3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) - - allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) - - allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) - - allocate(lattice_NslipSystem(lattice_maxNslipFamily,Nphases),source=0_pInt) - allocate(lattice_NtransSystem(lattice_maxNtransFamily,Nphases),source=0_pInt) allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) - allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionSlipTrans(lattice_maxNslip,lattice_maxNtrans,Nphases),source=0_pInt) ! other:me - allocate(lattice_interactionTransSlip(lattice_maxNtrans,lattice_maxNslip,Nphases),source=0_pInt) ! other:me + allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) + allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) + allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) allocate(CoverA(Nphases),source=0.0_pReal) allocate(CoverA_trans(Nphases),source=0.0_pReal) @@ -1377,8 +1336,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip - lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fcc_interactionSlipTrans - lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fcc_interactionTransSlip !-------------------------------------------------------------------------------------------------- ! bcc @@ -2392,9 +2349,32 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) NtransMax integer(pInt), dimension(:,:), allocatable :: interactionTypes + integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_fcc_Ntrans), parameter :: & + FCC_INTERACTIONSLIPTRANS = reshape(int( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! ---> trans + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip + 3,3,3,1,1,1,2,2,2,3,3,3, & + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],pInt),shape(FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc + select case(structure) case('fcc') - interactionTypes = LATTICE_FCC_INTERACTIONSLIPTRANS + interactionTypes = FCC_INTERACTIONSLIPTRANS NslipMax = LATTICE_FCC_NSLIPSYSTEM NtransMax = LATTICE_FCC_NTRANSSYSTEM case default @@ -2489,42 +2469,6 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r end function lattice_interaction_TwinSlip -!-------------------------------------------------------------------------------------------------- -!> @brief Populates trans-trans interaction matrix -!> details: only active transformation systems are considered -!-------------------------------------------------------------------------------------------------- -function lattice_interaction_TransSlip(Ntrans,Nslip,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer(pInt), dimension(:), intent(in) :: Ntrans, & !< number of active trans systems per family - Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values trans-trans - character(len=*), intent(in) :: & - structure !< lattice structure of parent crystal - real(pReal), dimension(sum(Ntrans),sum(Nslip)) :: interactionMatrix - - integer(pInt), dimension(:), allocatable :: NtransMax, & - NslipMax - integer(pInt), dimension(:,:), allocatable :: interactionTypes - - select case(structure) - case('fcc') - interactionTypes = LATTICE_FCC_INTERACTIONTRANSSLIP - NslipMax = LATTICE_FCC_NSLIPSYSTEM - NtransMax = LATTICE_FCC_NTRANSSYSTEM - case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (trans slip interaction)') - end select - - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Ntrans,Nslip,NtransMax,NslipMax,interactionValues,interactionTypes) - -end function lattice_interaction_TransSlip - - !-------------------------------------------------------------------------------------------------- !> @brief Calculates Schmid matrix for active slip systems !-------------------------------------------------------------------------------------------------- diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index dd150f3cb..c7c03c1f4 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -104,7 +104,6 @@ module plastic_dislotwin interaction_TwinSlip, & !< coefficients for twin-slip interaction for each interaction type interaction_TwinTwin, & !< coefficients for twin-twin interaction for each interaction type interaction_SlipTrans, & !< coefficients for slip-trans interaction for each interaction type - interaction_TransSlip, & !< coefficients for trans-slip interaction for each interaction type interaction_TransTrans !< coefficients for trans-trans interaction for each interaction type integer(pInt), dimension(:,:), allocatable :: & fcc_twinNucleationSlipPair ! ToDo: Better name? Is also use for trans @@ -190,7 +189,7 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine plastic_dislotwin_init(fileUnit) +subroutine plastic_dislotwin_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & @@ -230,8 +229,6 @@ subroutine plastic_dislotwin_init(fileUnit) use lattice implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt) :: Ninstance,& f,j,i,k,o,p, & offset_slip, index_myFamily, index_otherFamily, & @@ -240,7 +237,7 @@ subroutine plastic_dislotwin_init(fileUnit) integer(pInt) :: NipcMyPhase real(pReal), allocatable, dimension(:,:) :: temp1 - + integer(pInt), dimension(1,200), parameter :: lattice_ntranssystem = 12 ! HACK!! integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] @@ -450,10 +447,6 @@ subroutine plastic_dislotwin_init(fileUnit) prm%interaction_SlipTrans = lattice_interaction_SlipTrans(prm%Nslip,prm%Ntrans,& config_phase(p)%getFloats('interaction_sliptrans'), & structure(1:3)) - prm%interaction_TransSlip = lattice_interaction_TransSlip(prm%Ntrans,prm%Nslip,& - config_phase(p)%getFloats('interaction_transslip'), & - structure(1:3)) - if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] endif @@ -695,25 +688,23 @@ subroutine plastic_dislotwin_init(fileUnit) plasticState(p)%state0 = plasticState(p)%state dot%whole => plasticState(p)%dotState - allocate(mse%invLambdaSlip (prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTwin (prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTrans(prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTwin (prm%totalNtwin,NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlipTwin (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaSlipTrans (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(mse%mfp_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(mse%threshold_stress_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%mfp_slip(prm%totalNslip,NipcMyPhase), source=0.0_pReal) - allocate(mse%mfp_twin(prm%totalNtwin,NipcMyPhase), source=0.0_pReal) - allocate(mse%mfp_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(mse%invLambdaTwin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(mse%mfp_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(mse%threshold_stress_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(mse%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(mse%twinVolume (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%threshold_stress_slip(prm%totalNslip,NipcMyPhase), source=0.0_pReal) - allocate(mse%threshold_stress_twin(prm%totalNtwin,NipcMyPhase), source=0.0_pReal) + allocate(mse%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(mse%mfp_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(mse%threshold_stress_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - - allocate(mse%tau_r_twin(prm%totalNtwin,NipcMyPhase), source=0.0_pReal) - allocate(mse%tau_r_trans(prm%totalNtrans,NipcMyPhase), source=0.0_pReal) - - allocate(mse%twinVolume(prm%totalNtwin,NipcMyPhase), source=0.0_pReal) - allocate(mse%martensiteVolume(prm%totalNtrans,NipcMyPhase), source=0.0_pReal) + allocate(mse%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(mse%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) end associate enddo @@ -1076,12 +1067,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) real(pReal), dimension(plasticState(instance)%Nslip) :: & gdot_slip - - type(tParameters) :: prm - type(tDislotwinState) :: stt, dot - type(tDislotwinMicrostructure) :: mse - - associate(prm => param(instance), stt => state(instance), & dot => dotstate(instance), mse => microstructure(instance)) From 754e5a960bc7f06bd4094d4f80fcdab342449852 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 07:22:48 +0100 Subject: [PATCH 100/372] polishing sometimes gives segmentation fault/division by zero. probably the usual problem of dislotwin when running without friction coefficient B --- src/plastic_dislotwin.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index c7c03c1f4..6dbcb2b06 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -236,7 +236,6 @@ subroutine plastic_dislotwin_init integer(pInt) :: sizeState, sizeDotState integer(pInt) :: NipcMyPhase - real(pReal), allocatable, dimension(:,:) :: temp1 integer(pInt), dimension(1,200), parameter :: lattice_ntranssystem = 12 ! HACK!! integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] @@ -607,7 +606,6 @@ subroutine plastic_dislotwin_init ! DEPRECATED BEGIN - allocate(temp1(prm%totalNslip,prm%totalNtrans),source =0.0_pReal) allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) i = 0_pInt mySlipFamilies: do f = 1_pInt,size(prm%Nslip,1) From ef23095332b11aeb65b9ffdfb956a78004509787 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 08:03:40 +0100 Subject: [PATCH 101/372] using function for cleavage system definition only internally since damage related constitutive laws will be re-written anyway --- src/lattice.f90 | 122 ++++++++++++++++++++---------------------------- 1 file changed, 51 insertions(+), 71 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 6598c1dc1..6d4251fc9 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -775,18 +775,18 @@ module lattice !-------------------------------------------------------------------------------------------------- ! orthorhombic integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & - LATTICE_ortho_NcleavageSystem = int([1, 1, 1],pInt) !< # of cleavage systems per family for ortho + LATTICE_ort_NcleavageSystem = int([1, 1, 1],pInt) !< # of cleavage systems per family for ortho integer(pInt), parameter, private :: & - LATTICE_ortho_Ncleavage = sum(lattice_ortho_NcleavageSystem) !< total # of cleavage systems for ortho + LATTICE_ort_Ncleavage = sum(lattice_ort_NcleavageSystem) !< total # of cleavage systems for ortho - real(pReal), dimension(3+3,LATTICE_ortho_Ncleavage), parameter, private :: & - LATTICE_ortho_systemCleavage = reshape(real([& + real(pReal), dimension(3+3,LATTICE_ort_Ncleavage), parameter, private :: & + LATTICE_ort_systemCleavage = reshape(real([& ! Cleavage direction Plane normal 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, & 1, 0, 0, 0, 0, 1 & - ],pReal),[ 3_pInt + 3_pInt,LATTICE_ortho_Ncleavage]) + ],pReal),[ 3_pInt + 3_pInt,LATTICE_ort_Ncleavage]) ! BEGIN DEPRECATED integer(pInt), parameter, public :: & @@ -796,7 +796,7 @@ module lattice LATTICE_maxNtrans = LATTICE_fcc_Ntrans, & !< max # of transformation systems over lattice structures LATTICE_maxNcleavage = max(LATTICE_fcc_Ncleavage,LATTICE_bcc_Ncleavage, & LATTICE_hex_Ncleavage, & - LATTICE_iso_Ncleavage,LATTICE_ortho_Ncleavage), & !< max # of cleavage systems over lattice structures + LATTICE_iso_Ncleavage,LATTICE_ort_Ncleavage), & !< max # of cleavage systems over lattice structures LATTICE_maxNinteraction = 182_pInt !END DEPRECATED @@ -1192,7 +1192,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) cd, cn, ct integer(pInt) :: & i,j, & - myNslip = 0_pInt, myNtrans = 0_pInt, myNcleavage = 0_pInt + myNslip, myNtrans, myNcleavage real(pReal) :: c11bar, c12bar, c13bar, c14bar, c33bar, c44bar, A, B lattice_C66(1:6,1:6,myPhase) = lattice_symmetrizeC66(lattice_structure(myPhase),& @@ -1270,23 +1270,28 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_hydrogenfluxDiffusion33(1:3,1:3,myPhase)) lattice_hydrogenfluxMobility33 (1:3,1:3,myPhase) = lattice_symmetrize33(lattice_structure(myPhase),& lattice_hydrogenfluxMobility33 (1:3,1:3,myPhase)) + myNslip = 0_pInt + myNtrans = 0_pInt + myNcleavage = 0_pInt select case(lattice_structure(myPhase)) !-------------------------------------------------------------------------------------------------- ! fcc case (LATTICE_fcc_ID) - myNslip = LATTICE_FCC_NSLIP - myNtrans = lattice_fcc_Ntrans + myNslip = LATTICE_FCC_NSLIP + myNtrans = lattice_fcc_Ntrans myNcleavage = lattice_fcc_Ncleavage - do i = 1_pInt,myNslip ! assign slip system vectors + lattice_NslipSystem (1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip + + lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & + lattice_SchmidMatrix_cleavage(lattice_fcc_ncleavageSystem,'fcc',covera) + + do i = 1_pInt,myNslip sd(1:3,i) = lattice_fcc_systemSlip(1:3,i) sn(1:3,i) = lattice_fcc_systemSlip(4:6,i) enddo - do i = 1_pInt, myNcleavage ! assign cleavage system vectors - cd(1:3,i) = lattice_fcc_systemCleavage(1:3,i)/norm2(lattice_fcc_systemCleavage(1:3,i)) - cn(1:3,i) = lattice_fcc_systemCleavage(4:6,i)/norm2(lattice_fcc_systemCleavage(4:6,i)) - ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) - enddo ! Phase transformation select case(trans_lattice_structure(myPhase)) @@ -1333,16 +1338,20 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) Str = 0.0_pReal end select - lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem - lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem - lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! bcc case (LATTICE_bcc_ID) - myNslip = LATTICE_BCC_NSLIP - myNtrans = 0_pInt + myNslip = LATTICE_BCC_NSLIP myNcleavage = lattice_bcc_Ncleavage + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bcc_NslipSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bcc_NcleavageSystem + lattice_NnonSchmid(myPhase) = lattice_bcc_NnonSchmid + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bcc_interactionSlipSlip + + lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & + lattice_SchmidMatrix_cleavage(lattice_bcc_ncleavagesystem,'bcc',covera) + do i = 1_pInt,myNslip ! assign slip system vectors sd(1:3,i) = lattice_bcc_systemSlip(1:3,i) sn(1:3,i) = lattice_bcc_systemSlip(4:6,i) @@ -1365,22 +1374,19 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sns(1:3,1:3,1,6,i) = math_tensorproduct33(sdU, sdU) sns(1:3,1:3,2,6,i) = math_tensorproduct33(-sdU, -sdU) enddo - do i = 1_pInt, myNcleavage ! assign cleavage system vectors - cd(1:3,i) = lattice_bcc_systemCleavage(1:3,i)/norm2(lattice_bcc_systemCleavage(1:3,i)) - cn(1:3,i) = lattice_bcc_systemCleavage(4:6,i)/norm2(lattice_bcc_systemCleavage(4:6,i)) - ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) - enddo - lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bcc_NslipSystem - lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bcc_NcleavageSystem - lattice_NnonSchmid(myPhase) = lattice_bcc_NnonSchmid - lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bcc_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! hex (including conversion from miller-bravais (a1=a2=a3=c) to miller (a, b, c) indices) case (LATTICE_hex_ID) - myNslip = lattice_hex_Nslip - myNtrans = 0_pInt + myNslip = lattice_hex_Nslip myNcleavage = lattice_hex_Ncleavage + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_hex_NslipSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip + + lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & + lattice_SchmidMatrix_cleavage(lattice_fcc_ncleavagesystem,'hex',covera) + do i = 1_pInt,myNslip ! assign slip system vectors sd(1,i) = lattice_hex_systemSlip(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] sd(2,i) = (lattice_hex_systemSlip(1,i)+2.0_pReal*lattice_hex_systemSlip(2,i))*& @@ -1390,28 +1396,14 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sn(2,i) = (lattice_hex_systemSlip(5,i)+2.0_pReal*lattice_hex_systemSlip(6,i))/sqrt(3.0_pReal) sn(3,i) = lattice_hex_systemSlip(8,i)/CoverA enddo - do i = 1_pInt, myNcleavage ! cleavage system vectors - cd(1,i) = lattice_hex_systemCleavage(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] - cd(2,i) = (lattice_hex_systemCleavage(1,i)+2.0_pReal*lattice_hex_systemCleavage(2,i))*& - 0.5_pReal*sqrt(3.0_pReal) - cd(3,i) = lattice_hex_systemCleavage(4,i)*CoverA - cd(1:3,1) = cd(1:3,i)/norm2(cd(1:3,i)) - cn(1,i) = lattice_hex_systemCleavage(5,i) ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) - cn(2,i) = (lattice_hex_systemCleavage(5,i)+2.0_pReal*lattice_hex_systemCleavage(6,i))/sqrt(3.0_pReal) - cn(3,i) = lattice_hex_systemCleavage(8,i)/CoverA - cn(1:3,1) = cn(1:3,i)/norm2(cn(1:3,i)) - ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) - enddo - lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_hex_NslipSystem - lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem - lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! bct case (LATTICE_bct_ID) - myNtrans = 0_pInt myNslip = lattice_bct_Nslip - myNcleavage = 0_pInt + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bct_NslipSystem + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bct_interactionSlipSlip + do i = 1_pInt,myNslip ! assign slip system vectors sd(1:2,i) = lattice_bct_systemSlip(1:2,i) sd(3,i) = lattice_bct_systemSlip(3,i)*CoverA @@ -1420,35 +1412,25 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sdU = sd(1:3,i) / norm2(sd(1:3,i)) snU = sn(1:3,i) / norm2(sn(1:3,i)) enddo - lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bct_NslipSystem - lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bct_interactionSlipSlip !-------------------------------------------------------------------------------------------------- ! orthorhombic (no crystal plasticity) case (LATTICE_ort_ID) - myNslip = 0_pInt - myNtrans = 0_pInt - myNcleavage = lattice_ortho_Ncleavage - do i = 1_pInt, myNcleavage ! assign cleavage system vectors - cd(1:3,i) = lattice_iso_systemCleavage(1:3,i)/norm2(LATTICE_ortho_systemCleavage(1:3,i)) - cn(1:3,i) = lattice_iso_systemCleavage(4:6,i)/norm2(LATTICE_ortho_systemCleavage(4:6,i)) - ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) - enddo - lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_iso_NcleavageSystem + myNcleavage = lattice_ort_Ncleavage + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_ort_NcleavageSystem + + lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & + lattice_SchmidMatrix_cleavage(lattice_ort_NcleavageSystem,'ort',covera) !-------------------------------------------------------------------------------------------------- ! isotropic (no crystal plasticity) case (LATTICE_iso_ID) - myNslip = 0_pInt - myNtrans = 0_pInt myNcleavage = lattice_iso_Ncleavage - do i = 1_pInt, myNcleavage ! assign cleavage system vectors - cd(1:3,i) = lattice_iso_systemCleavage(1:3,i)/norm2(lattice_iso_systemCleavage(1:3,i)) - cn(1:3,i) = lattice_iso_systemCleavage(4:6,i)/norm2(lattice_iso_systemCleavage(4:6,i)) - ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) - enddo lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_iso_NcleavageSystem + lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & + lattice_SchmidMatrix_cleavage(lattice_iso_NcleavageSystem,'iso',covera) + !-------------------------------------------------------------------------------------------------- ! something went wrong case default @@ -1479,10 +1461,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_Strans(1:3,1:3,i,myPhase) = Str(1:3,1:3,i) lattice_shearTrans(i,myPhase) = trs(i) enddo + do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure - lattice_Scleavage(1:3,1:3,1,i,myPhase) = math_tensorproduct33(cd(1:3,i),cn(1:3,i)) - lattice_Scleavage(1:3,1:3,2,i,myPhase) = math_tensorproduct33(ct(1:3,i),cn(1:3,i)) - lattice_Scleavage(1:3,1:3,3,i,myPhase) = math_tensorproduct33(cn(1:3,i),cn(1:3,i)) do j = 1_pInt,3_pInt lattice_Scleavage_v(1:6,j,i,myPhase) = & math_Mandel33to6(math_symmetric33(lattice_Scleavage(1:3,1:3,j,i,myPhase))) @@ -2606,8 +2586,8 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE case('ort') - NcleavageMax = LATTICE_ORTHO_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_ORTHO_SYSTEMCLEAVAGE + NcleavageMax = LATTICE_ORT_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ORT_SYSTEMCLEAVAGE case('fcc') NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE From c29240c1c857e76cafe68bbe2bf145708d00e394 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 23:00:56 +0100 Subject: [PATCH 102/372] forestprojection can be calculated centrally --- src/lattice.f90 | 231 +++++++++++++++++++++++--------------- src/plastic_dislotwin.f90 | 20 +--- 2 files changed, 141 insertions(+), 110 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 6d4251fc9..25b96b65e 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -865,6 +865,7 @@ module lattice lattice_interaction_SlipTwin, & lattice_interaction_SlipTrans, & lattice_interaction_TwinSlip, & + lattice_forestProjection, & lattice_characteristicShear_Twin, & lattice_C66_twin @@ -1065,85 +1066,7 @@ end subroutine lattice_init !-------------------------------------------------------------------------------------------------- -!> @brief xxx -!-------------------------------------------------------------------------------------------------- -subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) - use math, only: & - math_crossproduct, & - math_tensorproduct33, & - math_mul33x33, & - math_mul33x3, & - math_axisAngleToR, & - INRAD, & - MATH_I3 - use IO, only: & - IO_error - - implicit none - integer(pInt), dimension(:), intent(in) :: & - Ntrans - real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & - S, Q - real(pReal), intent(in), optional :: & - cOverA, & - a_fcc, & - a_bcc - - real(pReal), dimension(3,3) :: & - R, & - U, & ! Bain deformation - B, & - ss, sd - real(pReal), dimension(3) :: & - x, y, z - integer(pInt) :: & - i - - - if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' - - - if (present(a_fcc) .and. present(a_bcc)) then ! fcc -> bcc transformation - if ( a_fcc <= 0.0_pReal .or. a_bcc <= 0.0_pReal) print*, 'mist' - do i = 1_pInt,sum(Ntrans) - R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation - lattice_fccTobcc_systemTrans(4,i)*INRAD) - B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system - lattice_fccTobcc_bainRot(4,i)*INRAD) - x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) - y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) - - U = (a_bcc/a_fcc)*math_tensorproduct33(x,x) & - + (a_bcc/a_fcc)*math_tensorproduct33(y,y) * sqrt(2.0_pReal) & - + (a_bcc/a_fcc)*math_tensorproduct33(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 - enddo - elseif (present(cOverA)) then - ss = MATH_I3 - sd = MATH_I3 - ss(1,3) = sqrt(2.0_pReal)/4.0_pReal - if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & - sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) - - do i = 1_pInt,sum(Ntrans) - x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) - z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) - y = -math_crossproduct(x,z) - 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 - enddo - endif - - -end subroutine lattice_Trans - - -!-------------------------------------------------------------------------------------------------- -!> @brief Calculation of Schmid matrices, etc. +!> @brief !!!!!!!DEPRECTATED!!!!!! !-------------------------------------------------------------------------------------------------- subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) use prec, only: & @@ -1385,7 +1308,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip lattice_Scleavage(1:3,1:3,1:3,1:myNcleavage,myPhase) = & - lattice_SchmidMatrix_cleavage(lattice_fcc_ncleavagesystem,'hex',covera) + lattice_SchmidMatrix_cleavage(lattice_hex_ncleavagesystem,'hex',covera) do i = 1_pInt,myNslip ! assign slip system vectors sd(1,i) = lattice_hex_systemSlip(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] @@ -1453,8 +1376,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_Sslip_v(1:6,j,i,myPhase) = & math_Mandel33to6(math_symmetric33(lattice_Sslip(1:3,1:3,j,i,myPhase))) enddo - if (abs(math_trace33(lattice_Sslip(1:3,1:3,1,i,myPhase))) > tol_math_check) & - call IO_error(0_pInt,myPhase,i,0_pInt,ext_msg = 'dilatational slip Schmid matrix') enddo do i = 1_pInt,myNtrans lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) @@ -1852,7 +1773,8 @@ end function lattice_C66_twin !> ToDo: Completely untested and incomplete !-------------------------------------------------------------------------------------------------- function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & - C_target66,structure_target) + C_target66,structure_target, & + CoverA_trans,a_bcc,a_fcc) use prec, only: & tol_math_check use IO, only: & @@ -1910,7 +1832,7 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & if (abs(C_target_unrotated66(i,i)) @brief Calculates Schmid matrix for active cleavage systems !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix) - use prec, only: & - tol_math_check + use math, only: & + math_tensorproduct33 use IO, only: & IO_error - use math, only: & - math_trace33, & - math_tensorproduct33 implicit none integer(pInt), dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix real(pReal), intent(in) :: cOverA + real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem real(pReal), dimension(:,:), allocatable :: cleavageSystems @@ -2617,6 +2536,57 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid end function lattice_SchmidMatrix_cleavage +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates forest projection (for edge dislocations) +!-------------------------------------------------------------------------------------------------- +function lattice_forestProjection(Nslip,structure,cOverA) result(projection) + use math, only: & + math_mul3x3 + use IO, only: & + IO_error + + implicit none + integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: slipSystems + integer(pInt), dimension(:), allocatable :: NslipMax + integer(pInt) :: i, j + + select case(structure) + case('fcc') + NslipMax = LATTICE_FCC_NSLIPSYSTEM + slipSystems = LATTICE_FCC_SYSTEMSLIP + case('bcc') + NslipMax = LATTICE_BCC_NSLIPSYSTEM + slipSystems = LATTICE_BCC_SYSTEMSLIP + case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + NslipMax = LATTICE_HEX_NSLIPSYSTEM + slipSystems = LATTICE_HEX_SYSTEMSLIP + case('bct') + NslipMax = LATTICE_BCT_NSLIPSYSTEM + slipSystems = LATTICE_BCT_SYSTEMSLIP + case default + call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_forrestProjection)') + end select + + if (any(NslipMax(1:size(Nslip)) - Nslip < 0_pInt)) & + call IO_error(145_pInt,ext_msg='Nslip '//trim(structure)) + if (any(Nslip < 0_pInt)) & + call IO_error(144_pInt,ext_msg='Nslip '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) + + do i=1_pInt, sum(Nslip); do j=1_pInt, sum(Nslip) + projection(i,j) = abs(math_mul3x3(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) + enddo; enddo + +end function lattice_forestProjection + + !-------------------------------------------------------------------------------------------------- !> @brief Populates reduced interaction matrix !-------------------------------------------------------------------------------------------------- @@ -2714,11 +2684,86 @@ function buildCoordinateSystem(active,maximum,system,structure,cOverA) buildCoordinateSystem(1:3,1,i) = direction/norm2(direction) buildCoordinateSystem(1:3,2,i) = normal/norm2(normal) - buildCoordinateSystem(1:3,3,i) = math_crossproduct(direction,normal) + buildCoordinateSystem(1:3,3,i) = math_crossproduct(buildCoordinateSystem(1:3,1,i),& + buildCoordinateSystem(1:3,2,i)) enddo activeSystems enddo activeFamilies end function buildCoordinateSystem +!-------------------------------------------------------------------------------------------------- +!> @brief xxx +!-------------------------------------------------------------------------------------------------- +subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) + use math, only: & + math_crossproduct, & + math_tensorproduct33, & + math_mul33x33, & + math_mul33x3, & + math_axisAngleToR, & + INRAD, & + MATH_I3 + use IO, only: & + IO_error + + implicit none + integer(pInt), dimension(:), intent(in) :: & + Ntrans + real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & + S, Q + real(pReal), intent(in), optional :: & + cOverA, & + a_fcc, & + a_bcc + + real(pReal), dimension(3,3) :: & + R, & + U, & ! Bain deformation + B, & + ss, sd + real(pReal), dimension(3) :: & + x, y, z + integer(pInt) :: & + i + + if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' + + if (present(a_fcc) .and. present(a_bcc)) then ! fcc -> bcc transformation + if ( a_fcc <= 0.0_pReal .or. a_bcc <= 0.0_pReal) print*, 'mist' + do i = 1_pInt,sum(Ntrans) + R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation + lattice_fccTobcc_systemTrans(4,i)*INRAD) + B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system + lattice_fccTobcc_bainRot(4,i)*INRAD) + x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) + y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) + z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) + + U = (a_bcc/a_fcc)*math_tensorproduct33(x,x) & + + (a_bcc/a_fcc)*math_tensorproduct33(y,y) * sqrt(2.0_pReal) & + + (a_bcc/a_fcc)*math_tensorproduct33(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 + enddo + elseif (present(cOverA)) then + ss = MATH_I3 + sd = MATH_I3 + ss(1,3) = sqrt(2.0_pReal)/4.0_pReal + if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & + sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) + + do i = 1_pInt,sum(Ntrans) + x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) + z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) + y = -math_crossproduct(x,z) + 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 + enddo + endif + +end subroutine lattice_Trans + end module lattice diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 6dbcb2b06..b28f59e92 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -302,9 +302,11 @@ subroutine plastic_dislotwin_init if(prm%fccTwinTransNucleation) & prm%fcc_twinNucleationSlipPair = lattice_fcc_twinNucleationSlipPair - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + prm%forestProjectionEdge= lattice_forestProjection (prm%Nslip,structure(1:3),& + config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config_phase(p)%getFloats('interaction_slipslip'), & structure(1:3)) @@ -606,22 +608,6 @@ subroutine plastic_dislotwin_init ! DEPRECATED BEGIN - allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) - i = 0_pInt - mySlipFamilies: do f = 1_pInt,size(prm%Nslip,1) - index_myFamily = sum(prm%Nslip(1:f-1_pInt)) - slipSystemsLoop: do j = 1_pInt,prm%Nslip(f) - i = i + 1_pInt - do o = 1_pInt, size(prm%Nslip,1) - index_otherFamily = sum(prm%Nslip(1:o-1_pInt)) - do k = 1_pInt,prm%Nslip(o) ! loop over (active) systems in other family (slip) - prm%forestProjectionEdge(index_myFamily+j,index_otherFamily+k) = & - abs(math_mul3x3(lattice_sn(:,sum(lattice_NslipSystem(1:f-1,p))+j,p), & - lattice_st(:,sum(lattice_NslipSystem(1:o-1,p))+k,p))) - enddo; enddo - enddo slipSystemsLoop - enddo mySlipFamilies - allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) i = 0_pInt From bf2b07478724e316bb28e2ae61fffd7a38fa6ea2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 11 Dec 2018 23:11:59 +0100 Subject: [PATCH 103/372] make parameters obvious --- src/lattice.f90 | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 25b96b65e..1c1c5644e 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -13,6 +13,7 @@ module lattice implicit none private + ! BEGIN DEPRECATED integer(pInt), parameter, public :: & LATTICE_maxNslipFamily = 13_pInt, & !< max # of slip system families over lattice structures @@ -40,7 +41,7 @@ module lattice lattice_st, & !< sd x sn lattice_sd !< slip direction of slip system - real(pReal), allocatable, dimension(:,:), protected, public :: & + real(pReal), allocatable, dimension(:,:), protected, private :: & lattice_shearTrans !< characteristic transformation shear integer(pInt), allocatable, dimension(:), protected, public :: & @@ -51,22 +52,22 @@ module lattice !-------------------------------------------------------------------------------------------------- ! face centered cubic integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & - LATTICE_fcc_NslipSystem = int([12, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for fcc + LATTICE_FCC_NSLIPSYSTEM = int([12, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for fcc integer(pInt), dimension(1), parameter, public :: & LATTICE_FCC_NTWINSYSTEM = int([12],pInt) !< # of twin systems per family for fcc integer(pInt), dimension(1), parameter, public :: & - LATTICE_fcc_NtransSystem = int([12],pInt) !< # of transformation systems per family for fcc + LATTICE_FCC_NTRANSSYSTEM = int([12],pInt) !< # of transformation systems per family for fcc integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & - LATTICE_fcc_NcleavageSystem = int([3, 4, 0],pInt) !< # of cleavage systems per family for fcc + LATTICE_FCC_NCLEAVAGESYSTEM = int([3, 4, 0],pInt) !< # of cleavage systems per family for fcc integer(pInt), parameter, private :: & - LATTICE_FCC_NSLIP = sum(lattice_fcc_NslipSystem), & !< total # of slip systems for fcc + LATTICE_FCC_NSLIP = sum(LATTICE_FCC_NSLIPSYSTEM), & !< total # of slip systems for fcc LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc - LATTICE_fcc_Ntrans = sum(lattice_fcc_NtransSystem), & !< total # of transformation systems for fcc - LATTICE_fcc_Ncleavage = sum(lattice_fcc_NcleavageSystem) !< total # of cleavage systems for fcc + LATTICE_FCC_NTRANS = sum(LATTICE_FCC_NTRANSSYSTEM), & !< total # of transformation systems for fcc + LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & LATTICE_fcc_systemSlip = reshape(real([& @@ -115,7 +116,7 @@ module lattice character(len=*), dimension(1), parameter, public :: LATTICE_FCC_TWINFAMILY_NAME = & ['<-2 1 1>{1 1 1}'] - real(pReal), dimension(3+3,LATTICE_fcc_Ntrans), parameter, private :: & + real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter, private :: & LATTICE_fccTohex_systemTrans = reshape(real( [& -2, 1, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, & @@ -148,6 +149,7 @@ module lattice 10,11 & ],pInt),shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) +! ToDo: should be in the interaction function integer(pInt), dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter, public :: & LATTICE_FCC_INTERACTIONSLIPSLIP = reshape(int( [& 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & ! ---> slip @@ -287,7 +289,7 @@ module lattice !-------------------------------------------------------------------------------------------------- ! body centered cubic integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & - LATTICE_bcc_NslipSystem = int([ 12, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], pInt) !< # of slip systems per family for bcc + LATTICE_BCC_NSLIPSYSTEM = int([ 12, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], pInt) !< # of slip systems per family for bcc integer(pInt), dimension(1), parameter, public :: & LATTICE_BCC_NTWINSYSTEM = int([12], pInt) !< # of twin systems per family for bcc @@ -296,7 +298,7 @@ module lattice LATTICE_bcc_NcleavageSystem = int([3, 6, 0],pInt) !< # of cleavage systems per family for bcc integer(pInt), parameter, private :: & - LATTICE_BCC_NSLIP = sum(lattice_bcc_NslipSystem), & !< total # of slip systems for bcc + LATTICE_BCC_NSLIP = sum(LATTICE_BCC_NSLIPSYSTEM), & !< total # of slip systems for bcc LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc LATTICE_bcc_NnonSchmid = 6_pInt, & !< total # of non-Schmid contributions for bcc (A. Koester, A. Ma, A. Hartmaier 2012) LATTICE_bcc_Ncleavage = sum(lattice_bcc_NcleavageSystem) !< total # of cleavage systems for bcc @@ -435,7 +437,7 @@ module lattice !-------------------------------------------------------------------------------------------------- ! hexagonal integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & - lattice_hex_NslipSystem = int([ 3, 3, 3, 6, 12, 6, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for hex + LATTICE_HEX_NSLIPSYSTEM = int([ 3, 3, 3, 6, 12, 6, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for hex integer(pInt), dimension(4), parameter, public :: & LATTICE_HEX_NTWINSYSTEM = int([ 6, 6, 6, 6],pInt) !< # of slip systems per family for hex @@ -444,11 +446,11 @@ module lattice LATTICE_hex_NcleavageSystem = int([3, 0, 0],pInt) !< # of cleavage systems per family for hex integer(pInt), parameter, private :: & - LATTICE_hex_Nslip = sum(lattice_hex_NslipSystem), & !< total # of slip systems for hex + LATTICE_HEX_NSLIP = sum(LATTICE_HEX_NSLIPSystem), & !< total # of slip systems for hex LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex LATTICE_hex_Ncleavage = sum(lattice_hex_NcleavageSystem) !< total # of cleavage systems for hex - real(pReal), dimension(4+4,LATTICE_hex_Nslip), parameter, private :: & + real(pReal), dimension(4+4,LATTICE_HEX_NSLIP), parameter, private :: & LATTICE_hex_systemSlip = reshape(real([& ! Slip direction Plane normal ! Basal systems <11.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base)) @@ -539,7 +541,7 @@ module lattice '<1 1 . -3>{1 1 . 2} '] - integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Nslip), parameter, public :: & + integer(pInt), dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NSLIP), parameter, public :: & LATTICE_hex_interactionSlipSlip = reshape(int( [& 1, 2, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! ---> slip 2, 1, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! | @@ -790,7 +792,7 @@ module lattice ! BEGIN DEPRECATED integer(pInt), parameter, public :: & - LATTICE_maxNslip = max(LATTICE_FCC_NSLIP,LATTICE_BCC_NSLIP,LATTICE_hex_Nslip, & + LATTICE_maxNslip = max(LATTICE_FCC_NSLIP,LATTICE_BCC_NSLIP,LATTICE_HEX_NSLIP, & LATTICE_bct_Nslip), & !< max # of slip systems over lattice structures LATTICE_maxNnonSchmid = LATTICE_bcc_NnonSchmid, & !< max # of non-Schmid contributions over lattice structures LATTICE_maxNtrans = LATTICE_fcc_Ntrans, & !< max # of transformation systems over lattice structures @@ -1111,8 +1113,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) xtr, ytr, ztr real(pReal), dimension(3,3,lattice_maxNtrans) :: & Rtr, Utr, Btr, Qtr, Str - real(pReal), dimension(3,lattice_maxNcleavage) :: & - cd, cn, ct integer(pInt) :: & i,j, & myNslip, myNtrans, myNcleavage @@ -1301,9 +1301,9 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) !-------------------------------------------------------------------------------------------------- ! hex (including conversion from miller-bravais (a1=a2=a3=c) to miller (a, b, c) indices) case (LATTICE_hex_ID) - myNslip = lattice_hex_Nslip + myNslip = LATTICE_HEX_NSLIP myNcleavage = lattice_hex_Ncleavage - lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_hex_NslipSystem + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = LATTICE_HEX_NSLIPSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip From 1446e9f4abd951ef68a489efb78dbd8069e47d9a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 12 Dec 2018 00:29:19 +0100 Subject: [PATCH 104/372] polished sanity checks + documentation --- src/IO.f90 | 4 + src/lattice.f90 | 396 ++++++++++++++++++++++++------------------------ 2 files changed, 199 insertions(+), 201 deletions(-) diff --git a/src/IO.f90 b/src/IO.f90 index af59b11b9..9ab6c81b7 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -1236,6 +1236,10 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) msg = 'zero entry on stiffness diagonal' case (136_pInt) msg = 'zero entry on stiffness diagonal for transformed phase' + case (137_pInt) + msg = 'not defined for lattice structure' + case (138_pInt) + msg = 'not enough interaction parameters given' !-------------------------------------------------------------------------------------------------- ! errors related to the parsing of material.config diff --git a/src/lattice.f90 b/src/lattice.f90 index 1c1c5644e..34535c7f0 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -3,8 +3,8 @@ !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief defines lattice structure definitions, slip and twin system definitions, Schimd matrix -!> calculation and non-Schmid behavior +!> @brief contains lattice structure definitions including Schmid matrices for slip, twin, trans, +! and cleavage as well as interaction among the various systems !-------------------------------------------------------------------------------------------------- module lattice use prec, only: & @@ -24,7 +24,7 @@ module lattice lattice_NcleavageSystem !< total # of transformation systems in each family integer(pInt), allocatable, dimension(:,:,:), protected, public :: & - lattice_interactionSlipSlip !< Slip--slip interaction type + lattice_interactionSlipSlip !< Slip--slip interaction type real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & lattice_Sslip, & !< Schmid and non-Schmid matrices @@ -111,7 +111,7 @@ module lattice 2, 1,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, & -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli + ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli character(len=*), dimension(1), parameter, public :: LATTICE_FCC_TWINFAMILY_NAME = & ['<-2 1 1>{1 1 1}'] @@ -164,13 +164,13 @@ module lattice 4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, & 5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, & 6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, & - - 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & - 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & - 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & - 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & - 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & - 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & + + 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & + 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & + 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & + 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & + 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & + 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & ],pInt),shape(LATTICE_FCC_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for fcc !< 1: self interaction !< 2: coplanar interaction @@ -222,7 +222,7 @@ module lattice real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & LATTICE_FCCTOBCC_BAINROT = reshape([& - 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant + 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant 1.0, 0.0, 0.0, 45.0, & 1.0, 0.0, 0.0, 45.0, & 1.0, 0.0, 0.0, 45.0, & @@ -1383,7 +1383,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_shearTrans(i,myPhase) = trs(i) enddo - do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure + do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure do j = 1_pInt,3_pInt lattice_Scleavage_v(1:6,j,i,myPhase) = & math_Mandel33to6(math_symmetric33(lattice_Scleavage(1:3,1:3,j,i,myPhase))) @@ -1395,6 +1395,7 @@ end subroutine lattice_initializeStructure !-------------------------------------------------------------------------------------------------- !> @brief Symmetrizes stiffness matrix according to lattice type +!> @details J. A. Rayne and B. S. Chandrasekhar Phys. Rev. 120, 1658 Erratum Phys. Rev. 122, 1962 !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrizeC66(struct,C66) @@ -1457,7 +1458,7 @@ pure function lattice_symmetrizeC66(struct,C66) lattice_symmetrizeC66(3,2) = C66(1,3) lattice_symmetrizeC66(4,4) = C66(4,4) lattice_symmetrizeC66(5,5) = C66(4,4) - lattice_symmetrizeC66(6,6) = C66(6,6) !J. A. Rayne and B. S. Chandrasekhar Phys. Rev. 120, 1658 Erratum Phys. Rev. 122, 1962 + lattice_symmetrizeC66(6,6) = C66(6,6) case default lattice_symmetrizeC66 = C66 end select @@ -1558,14 +1559,14 @@ pure function lattice_qDisorientation(Q1, Q2, struct) real(pReal), dimension(4,36), parameter :: & symOperations = reshape([& - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry + 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & @@ -1573,7 +1574,7 @@ real(pReal), dimension(4,36), parameter :: & -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry + 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & @@ -1583,19 +1584,19 @@ real(pReal), dimension(4,36), parameter :: & 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & ! - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry + 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & - ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 + ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 !-------------------------------------------------------------------------------------------------- ! check if a structure with known symmetries is given @@ -1643,32 +1644,25 @@ end function lattice_qDisorientation !-------------------------------------------------------------------------------------------------- -!> @brief Provides characteristtic shear for twinning +!> @brief Characteristic shear for twinning !-------------------------------------------------------------------------------------------------- function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(characteristicShear) use IO, only: & IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=3), intent(in) :: structure - real(pReal), intent(in), optional :: & - cOverA - real(pReal), dimension(sum(Ntwin)) :: characteristicShear + integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=3), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Ntwin)) :: characteristicShear integer(pInt) :: & - ir, & !< index in reduced list - ig, & !< index in full list + a, & !< index of active system + c, & !< index in complete system list mf, & !< index of my family ms !< index of my system in current family - real(pReal), dimension(LATTICE_FCC_NTWIN), parameter :: & - FCC_SHEARTWIN = 0.5_pReal*sqrt(2.0_pReal) - - real(pReal), dimension(LATTICE_BCC_NTWIN), parameter :: & - BCC_SHEARTWIN = 0.5_pReal*sqrt(2.0_pReal) - integer(pInt), dimension(LATTICE_HEX_NTWIN), parameter :: & - HEX_SHEARTWIN = reshape(int( [& + HEX_SHEARTWIN = reshape(int( [& 1, & ! <-10.1>{10.2} 1, & 1, & @@ -1693,32 +1687,31 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact 4, & 4, & 4 & - ],pInt),[LATTICE_HEX_NTWIN]) ! indicator to formula further below + ],pInt),[LATTICE_HEX_NTWIN]) ! indicator to formulas below - ir = 0_pInt + a = 0_pInt myFamilies: do mf = 1_pInt,size(Ntwin,1) mySystems: do ms = 1_pInt,Ntwin(mf) - ir = ir + 1_pInt - select case(structure) - case('fcc') - ig = sum(LATTICE_FCC_NTWINSYSTEM(1:mf-1))+ms - characteristicShear(ir) = FCC_SHEARTWIN(ig) - case('bcc') - ig = sum(LATTICE_BCC_NTWINSYSTEM(1:mf-1))+ms - characteristicShear(ir) = BCC_SHEARTWIN(ig) + a = a + 1_pInt + select case(trim(structure)) + case('fcc','bcc') + characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) case('hex') - if (.not. present(CoverA)) call IO_error(0_pInt) - ig = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms - select case(HEX_SHEARTWIN(ig)) ! from Christian & Mahajan 1995 p.29 + if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & + call IO_error(131_pInt,ext_msg='lattice_characteristicShear_Twin') + c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms + select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29 case (1_pInt) ! <-10.1>{10.2} - characteristicShear(ir) = (3.0_pReal-cOverA*cOverA)/sqrt(3.0_pReal)/CoverA + characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA case (2_pInt) ! <11.6>{-1-1.1} - characteristicShear(ir) = 1.0_pReal/cOverA + characteristicShear(a) = 1.0_pReal/cOverA case (3_pInt) ! <10.-2>{10.1} - characteristicShear(ir) = (4.0_pReal*cOverA*cOverA-9.0_pReal)/sqrt(48.0_pReal)/cOverA + characteristicShear(a) = (4.0_pReal*cOverA**2.0_pReal-9.0_pReal)/sqrt(48.0_pReal)/cOverA case (4_pInt) ! <11.-3>{11.2} - characteristicShear(ir) = 2.0_pReal*(cOverA*cOverA-2.0_pReal)/3.0_pReal/cOverA + characteristicShear(a) = 2.0_pReal*(cOverA**2.0_pReal-2.0_pReal)/3.0_pReal/cOverA end select + case default + call IO_error(137_pInt,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) end select enddo mySystems enddo myFamilies @@ -1727,7 +1720,7 @@ end function lattice_characteristicShear_Twin !-------------------------------------------------------------------------------------------------- -!> @brief Calculates rotated elasticity matrices for twinning +!> @brief Rotated elasticity matrices for twinning in Mandel notation !-------------------------------------------------------------------------------------------------- function lattice_C66_twin(Ntwin,C66,structure,CoverA) use IO, only: & @@ -1742,25 +1735,29 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) implicit none integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C66 - real(pReal), intent(in) :: cOverA - real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin + real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin - real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem + real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem - real(pReal), dimension(3,3) :: R + real(pReal), dimension(3,3) :: R integer(pInt) :: i - select case(structure) + select case(trim(structure)) case('fcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,structure,cOverA) + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) case('bcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,structure,cOverA) + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) case('hex','hexagonal') !ToDo: "No alias policy": long or short? - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,'hex',cOverA) + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& + 'hex',cOverA) case default - call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_C66_twin)') + call IO_error(137_pInt,ext_msg='lattice_C66_twin: '//trim(structure)) end select + do i = 1, sum(Ntwin) R = math_axisAngleToR(coordinateSystem(1:3,2,i), 180.0_pReal * INRAD) ! ToDo: Why always 180 deg? lattice_C66_twin(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(math_Mandel66to3333(C66),R)) @@ -1769,8 +1766,8 @@ end function lattice_C66_twin !-------------------------------------------------------------------------------------------------- -!> @brief Calculates rotated elasticity matrices for transformation -!> ToDo: Completely untested and incomplete +!> @brief Rotated elasticity matrices for transformation in Mandel notation +!> ToDo: Completely untested and incomplete and undocumented !-------------------------------------------------------------------------------------------------- function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & C_target66,structure_target, & @@ -1791,7 +1788,7 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & math_crossproduct implicit none - integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family character(len=*), intent(in) :: & structure_target, & !< lattice structure structure_parent !< lattice structure @@ -1840,16 +1837,14 @@ lattice_C66_trans = 0.0_pReal end function - !-------------------------------------------------------------------------------------------------- -!> @brief Non-schmid tensor -!> ToDo: Clean description needed -! Schmid matrices with non-Schmid contributions according to Koester_etal2012, Acta Materialia 60 (2012) -! 3894–3901, eq. (17) ("n1" is replaced by either "np" or "nn" according to either positive or negative slip direction) -! "np" and "nn" according to Gröger_etal2008, Acta Materialia 56 (2008) 5412–5425, table 1 -! (corresponds to their "n1" for positive and negative slip direction respectively) +!> @brief Non-schmid projections for bcc with up to 6 coefficients +! Koester et al. 2012, Acta Materialia 60 (2012) 3894–3901, eq. (17) +! Gröger et al. 2008, Acta Materialia 56 (2008) 5412–5425, table 1 !-------------------------------------------------------------------------------------------------- function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix) + use IO, only: & + IO_error use math, only: & INRAD, & math_tensorproduct33, & @@ -1857,21 +1852,22 @@ function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSc math_mul33x3, & math_axisAngleToR implicit none - integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients - integer(pInt), intent(in) :: sense !< sense (-1,+1) + integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections + integer(pInt), intent(in) :: sense !< sense (-1,+1) + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix - - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem - real(pReal), dimension(:), allocatable :: direction - real(pReal), dimension(:), allocatable :: normal,np + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system + real(pReal), dimension(:), allocatable :: & + direction, normal, np integer(pInt) :: i - if (abs(sense) /= 1_pInt) write(6,*) 'mist' - coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,'bcc',0.0_pReal) - coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) - nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) + if (abs(sense) /= 1_pInt) call IO_error(0_pInt,ext_msg='lattice_nonSchmidMatrix') + + coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,& + 'bcc',0.0_pReal) + coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) ! convert unidirectional coordinate system + nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) ! Schmid contribution do i = 1_pInt,sum(Nslip) direction = coordinateSystem(1:3,1,i) @@ -1895,8 +1891,8 @@ end function lattice_nonSchmidMatrix !-------------------------------------------------------------------------------------------------- -!> @brief Populates slip-slip interaction matrix -!> details: only active slip systems are considered +!> @brief Slip-slip interaction matrix +!> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipSlip(Nslip,interactionValues,structure) result(interactionMatrix) use IO, only: & @@ -1904,7 +1900,7 @@ function lattice_interaction_SlipSlip(Nslip,interactionValues,structure) result( implicit none integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values slip-slip + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix @@ -1925,20 +1921,17 @@ function lattice_interaction_SlipSlip(Nslip,interactionValues,structure) result( interactionTypes = LATTICE_BCT_INTERACTIONSLIPSLIP NslipMax = LATTICE_BCT_NSLIPSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (slip slip interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipSlip: '//trim(structure)) end select - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Nslip,Nslip,NslipMax,NslipMax,interactionValues,interactionTypes) end function lattice_interaction_SlipSlip !-------------------------------------------------------------------------------------------------- -!> @brief Populates twin-twin interaction matrix -!> details: only active twin systems are considered +!> @brief Twin-twin interaction matrix +!> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result(interactionMatrix) use IO, only: & @@ -1946,7 +1939,7 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( implicit none integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix @@ -1967,7 +1960,7 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1 & - ],pInt),shape(FCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for fcc + ],pInt),shape(FCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin-twin interaction types for fcc integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & BCC_INTERACTIONTWINTWIN = reshape(int( [& @@ -1983,7 +1976,7 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( 3,3,3,2,2,3,3,3,3,1,3,3, & 2,3,3,3,3,3,3,2,3,3,1,3, & 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),shape(BCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for bcc + ],pInt),shape(BCC_INTERACTIONTWINTWIN),order=[2,1]) !< Twin-twin interaction types for bcc !< 1: self interaction !< 2: collinear interaction !< 3: other interaction @@ -2016,7 +2009,7 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & - ],pInt),shape(HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 16 in total) + ],pInt),shape(HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin-twin interaction types for hex select case(structure) case('fcc') @@ -2029,30 +2022,26 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( interactionTypes = HEX_INTERACTIONTWINTWIN NtwinMax = LATTICE_HEX_NTWINSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (twin twin interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_TwinTwin: '//trim(structure)) end select - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Ntwin,Ntwin,NtwinMax,NtwinMax,interactionValues,interactionTypes) end function lattice_interaction_TwinTwin !-------------------------------------------------------------------------------------------------- -!> @brief Populates trans-trans interaction matrix -!> details: only active transformation systems are considered +!> @brief Trans-trans interaction matrix +!> details only active trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TransTrans(Ntrans,interactionValues,structure) result(interactionMatrix) use IO, only: & IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin - character(len=*), intent(in) :: & - structure !< lattice structure of parent crystal + integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction + character(len=*), intent(in) :: structure !< lattice structure (parent crystal) real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix integer(pInt), dimension(:), allocatable :: NtransMax @@ -2072,24 +2061,23 @@ function lattice_interaction_TransTrans(Ntrans,interactionValues,structure) resu 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1, & 2,2,2,2,2,2,2,2,2,1,1,1 & - ],pInt),shape(FCC_INTERACTIONTRANSTRANS),order=[2,1]) !< Trans--trans interaction types for fcc + ],pInt),shape(FCC_INTERACTIONTRANSTRANS),order=[2,1]) !< Trans-trans interaction types for fcc if (trim(structure) == 'fcc') then interactionTypes = FCC_INTERACTIONTRANSTRANS NtransMax = LATTICE_FCC_NTRANSSYSTEM else - call IO_error(132_pInt,ext_msg=trim(structure)//' (trans trans interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_TransTrans: '//trim(structure)) end if - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) + end function lattice_interaction_TransTrans !-------------------------------------------------------------------------------------------------- -!> @brief Populates slip-twin interaction matrix -!> details: only active slip and twin systems are considered +!> @brief Slip-twin interaction matrix +!> details only active slip and twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) result(interactionMatrix) use IO, only: & @@ -2098,7 +2086,7 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r implicit none integer(pInt), dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix @@ -2127,7 +2115,7 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4 & - ],pInt),shape(FCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for fcc + ],pInt),shape(FCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip-twin interaction types for fcc !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction @@ -2158,7 +2146,7 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r 3,3,3,2,2,3,3,3,3,1,3,3, & 2,3,3,3,3,3,3,2,3,3,1,3, & 3,2,3,3,3,3,2,3,3,3,3,1 & - ],pInt),shape(BCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for bcc + ],pInt),shape(BCC_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip-twin interaction types for bcc !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction @@ -2203,7 +2191,7 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & ! - ],pInt),shape(HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) + ],pInt),shape(HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip-twin interaction types for hex select case(structure) @@ -2220,20 +2208,17 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r NslipMax = LATTICE_HEX_NSLIPSYSTEM NtwinMax = LATTICE_HEX_NTWINSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (slip twin interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipTwin: '//trim(structure)) end select - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Nslip,Ntwin,NslipMax,NtwinMax,interactionValues,interactionTypes) end function lattice_interaction_SlipTwin !-------------------------------------------------------------------------------------------------- -!> @brief Populates trans-trans interaction matrix -!> details: only active transformation systems are considered +!> @brief Slip-trans interaction matrix +!> details only active slip and trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) result(interactionMatrix) use IO, only: & @@ -2242,9 +2227,9 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) implicit none integer(pInt), dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values slip--trans + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction character(len=*), intent(in) :: & - structure !< lattice structure of parent crystal + structure !< lattice structure (parent crystal) real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix integer(pInt), dimension(:), allocatable :: NslipMax, & @@ -2265,14 +2250,14 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) 3,3,3,2,2,2,3,3,3,1,1,1, & 2,2,2,3,3,3,3,3,3,1,1,1, & 3,3,3,3,3,3,2,2,2,1,1,1, & - + 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4, & 4,4,4,4,4,4,4,4,4,4,4,4 & - ],pInt),shape(FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip--trans interaction types for fcc + ],pInt),shape(FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip-trans interaction types for fcc select case(structure) case('fcc') @@ -2280,19 +2265,17 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) NslipMax = LATTICE_FCC_NSLIPSYSTEM NtransMax = LATTICE_FCC_NTRANSSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (slip trans interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipTrans: '//trim(structure)) end select - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo interactionMatrix = buildInteraction(Nslip,Ntrans,NslipMax,NtransMax,interactionValues,interactionTypes) end function lattice_interaction_SlipTrans !-------------------------------------------------------------------------------------------------- -!> @brief Populates twin-slip interaction matrix -!> details: only active twin and slip systems are considered +!> @brief Twin-slip interaction matrix +!> details only active twin and slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) result(interactionMatrix) use IO, only: & @@ -2301,7 +2284,7 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r implicit none integer(pInt), dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< interaction values twin-twin + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction character(len=*), intent(in) :: structure !< lattice structure real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix @@ -2310,10 +2293,10 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r integer(pInt), dimension(:,:), allocatable :: interactionTypes integer(pInt), dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONTWINSLIP = 1_pInt !< Twin--Slip interaction types for fcc + FCC_INTERACTIONTWINSLIP = 1_pInt !< Twin-Slip interaction types for fcc integer(pInt), dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & - BCC_INTERACTIONTWINSLIP = 1_pInt !< Twin--slip interaction types for bcc + BCC_INTERACTIONTWINSLIP = 1_pInt !< Twin-slip interaction types for bcc integer(pInt), dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & HEX_INTERACTIONTWINSLIP = reshape(int( [& @@ -2344,7 +2327,7 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & - ],pInt),shape(HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) + ],pInt),shape(HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin-twin interaction types for hex select case(structure) case('fcc') @@ -2360,19 +2343,17 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r NtwinMax = LATTICE_HEX_NTWINSYSTEM NslipMax = LATTICE_HEX_NSLIPSYSTEM case default - call IO_error(132_pInt,ext_msg=trim(structure)//' (twin slip interaction)') + call IO_error(137_pInt,ext_msg='lattice_interaction_TwinSlip: '//trim(structure)) end select - !if (size(interactionValues) > maxval(interactionTypes)) & - ! call IO_error(0_pInt) ! ToDo - interactionMatrix = buildInteraction(Ntwin,Nslip,NtwinMax,NslipMax,interactionValues,interactionTypes) end function lattice_interaction_TwinSlip !-------------------------------------------------------------------------------------------------- -!> @brief Calculates Schmid matrix for active slip systems +!> @brief Schmid matrix for slip +!> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) use prec, only: & @@ -2384,14 +2365,14 @@ function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) math_tensorproduct33 implicit none - integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure + integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure real(pReal), intent(in) :: cOverA real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pReal), dimension(:,:), allocatable :: slipSystems - integer(pInt), dimension(:), allocatable :: NslipMax + integer(pInt), dimension(:), allocatable :: NslipMax integer(pInt) :: i select case(structure) @@ -2408,7 +2389,7 @@ function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) NslipMax = LATTICE_BCT_NSLIPSYSTEM slipSystems = LATTICE_BCT_SYSTEMSLIP case default - call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_SchmidMatrix_slip)') + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) end select if (any(NslipMax(1:size(Nslip)) - Nslip < 0_pInt)) & @@ -2428,7 +2409,8 @@ end function lattice_SchmidMatrix_slip !-------------------------------------------------------------------------------------------------- -!> @brief Calculates Schmid matrix for active twin systems +!> @brief Schmid matrix for twinning +!> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) use prec, only: & @@ -2440,14 +2422,14 @@ function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) math_tensorproduct33 implicit none - integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA + integer(pInt), dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem real(pReal), dimension(:,:), allocatable :: twinSystems - integer(pInt), dimension(:), allocatable :: NtwinMax + integer(pInt), dimension(:), allocatable :: NtwinMax integer(pInt) :: i select case(structure) @@ -2461,14 +2443,14 @@ function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) NtwinMax = LATTICE_HEX_NTWINSYSTEM twinSystems = LATTICE_HEX_SYSTEMTWIN case default - call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_SchmidMatrix_twin)') + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) end select if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0_pInt)) & call IO_error(145_pInt,ext_msg='Ntwin '//trim(structure)) if (any(Ntwin < 0_pInt)) & call IO_error(144_pInt,ext_msg='Ntwin '//trim(structure)) - + coordinateSystem = buildCoordinateSystem(Ntwin,NtwinMax,twinSystems,structure,cOverA) do i = 1, sum(Ntwin) @@ -2481,7 +2463,8 @@ end function lattice_SchmidMatrix_twin !-------------------------------------------------------------------------------------------------- -!> @brief Calculates Schmid matrix for active cleavage systems +!> @brief Schmid matrix for cleavage +!> details only active cleavage systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix) use math, only: & @@ -2490,9 +2473,9 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA + integer(pInt), dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem @@ -2517,7 +2500,7 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE case default - call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_SchmidMatrix_cleavage)') + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) end select if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0_pInt)) & @@ -2537,7 +2520,7 @@ end function lattice_SchmidMatrix_cleavage !-------------------------------------------------------------------------------------------------- -!> @brief Calculates forest projection (for edge dislocations) +!> @brief Forest projection (for edge dislocations) !-------------------------------------------------------------------------------------------------- function lattice_forestProjection(Nslip,structure,cOverA) result(projection) use math, only: & @@ -2546,9 +2529,9 @@ function lattice_forestProjection(Nslip,structure,cOverA) result(projection) IO_error implicit none - integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA + integer(pInt), dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem @@ -2570,7 +2553,7 @@ function lattice_forestProjection(Nslip,structure,cOverA) result(projection) NslipMax = LATTICE_BCT_NSLIPSYSTEM slipSystems = LATTICE_BCT_SYSTEMSLIP case default - call IO_error(130_pInt,ext_msg=trim(structure)//' (lattice_forrestProjection)') + call IO_error(137_pInt,ext_msg='lattice_forestProjection: '//trim(structure)) end select if (any(NslipMax(1:size(Nslip)) - Nslip < 0_pInt)) & @@ -2579,7 +2562,7 @@ function lattice_forestProjection(Nslip,structure,cOverA) result(projection) call IO_error(144_pInt,ext_msg='Nslip '//trim(structure)) coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) - + do i=1_pInt, sum(Nslip); do j=1_pInt, sum(Nslip) projection(i,j) = abs(math_mul3x3(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) enddo; enddo @@ -2590,8 +2573,9 @@ end function lattice_forestProjection !-------------------------------------------------------------------------------------------------- !> @brief Populates reduced interaction matrix !-------------------------------------------------------------------------------------------------- -pure function buildInteraction(activeA,activeB,maxA,maxB,values,matrix) - +function buildInteraction(activeA,activeB,maxA,maxB,values,matrix) + use IO, only: & + IO_error implicit none integer(pInt), dimension(:), intent(in) :: & activeA, & !< number of active systems as specified in material.config @@ -2599,7 +2583,7 @@ pure function buildInteraction(activeA,activeB,maxA,maxB,values,matrix) maxA, & !< number of maximum available systems maxB !< number of maximum available systems real(pReal), dimension(:), intent(in) :: values !< interaction values - integer(pInt), dimension(:,:), intent(in) :: matrix !< full interaction matrix + integer(pInt), dimension(:,:), intent(in) :: matrix !< complete interaction matrix real(pReal), dimension(sum(activeA),sum(activeB)) :: buildInteraction integer(pInt) :: & @@ -2613,6 +2597,8 @@ pure function buildInteraction(activeA,activeB,maxA,maxB,values,matrix) otherFamilies: do of = 1_pInt,size(activeB,1) index_otherFamily = sum(activeB(1:of-1_pInt)) otherSystems: do os = 1_pInt,activeB(of) + if(matrix(sum(maxA(1:mf-1))+ms, sum(maxB(1:of-1))+os) > size(values)) & + call IO_error(138,ext_msg='buildInteraction') buildInteraction(index_myFamily+ms,index_otherFamily+os) = & values(matrix(sum(maxA(1:mf-1))+ms, sum(maxB(1:of-1))+os)) enddo otherSystems; enddo otherFamilies; @@ -2624,16 +2610,18 @@ end function buildInteraction !-------------------------------------------------------------------------------------------------- !> @brief build a local coordinate system in a slip, twin, trans, cleavage system -!> @details: Order: Direction, plane (normal), and common perpendicular +!> @details Order: Direction, plane (normal), and common perpendicular !-------------------------------------------------------------------------------------------------- -function buildCoordinateSystem(active,maximum,system,structure,cOverA) +function buildCoordinateSystem(active,complete,system,structure,cOverA) + use IO, only: & + IO_error use math, only: & math_crossproduct implicit none integer(pInt), dimension(:), intent(in) :: & active, & - maximum + complete real(pReal), dimension(:,:), intent(in) :: & system character(len=*), intent(in) :: & @@ -2646,46 +2634,50 @@ function buildCoordinateSystem(active,maximum,system,structure,cOverA) real(pReal), dimension(3) :: & direction, normal integer(pInt) :: & - i, & !< index in reduced matrix - j, & !< index in full matrix + a, & !< index of active system + c, & !< index in complete system matrix f, & !< index of my family s !< index of my system in current family - i = 0_pInt + a = 0_pInt activeFamilies: do f = 1_pInt,size(active,1) activeSystems: do s = 1_pInt,active(f) - i = i + 1_pInt - j = sum(maximum(1:f-1))+s + a = a + 1_pInt + c = sum(complete(1:f-1))+s select case(trim(structure)) case ('fcc','bcc') - direction = system(1:3,j) - normal = system(4:6,j) - - case ('hex') - !ToDo: check if c/a ratio is sensible - ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) - direction = [ system(1,j)*1.5_pReal, & - (system(1,j)+2.0_pReal*system(2,j))*sqrt(0.75_pReal), & - system(4,j)*CoverA ] + direction = system(1:3,c) + normal = system(4:6,c) - ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) - normal = [ system(5,j), & - (system(5,j)+2.0_pReal*system(6,j))/ sqrt(3.0_pReal), & - system(8,j)/CoverA ] + case ('hex') + if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & + call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) + + direction = [ system(1,c)*1.5_pReal, & + (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & + system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) + + normal = [ system(5,c), & + (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & + system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) case ('bct') - !ToDo: check if c/a ratio is sensible - direction = [system(1:2,j),system(3,i)*CoverA] - normal = [system(4:5,j),system(6,i)/CoverA] + if (cOverA > 2.0_pReal) & + call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) + direction = [system(1:2,c),system(3,c)*cOverA] + normal = [system(4:5,c),system(6,c)/cOverA] + + case default + call IO_error(137_pInt,ext_msg='buildCoordinateSystem: '//trim(structure)) end select - buildCoordinateSystem(1:3,1,i) = direction/norm2(direction) - buildCoordinateSystem(1:3,2,i) = normal/norm2(normal) - buildCoordinateSystem(1:3,3,i) = math_crossproduct(buildCoordinateSystem(1:3,1,i),& - buildCoordinateSystem(1:3,2,i)) + buildCoordinateSystem(1:3,1,a) = direction/norm2(direction) + buildCoordinateSystem(1:3,2,a) = normal/norm2(normal) + buildCoordinateSystem(1:3,3,a) = math_crossproduct(buildCoordinateSystem(1:3,1,a),& + buildCoordinateSystem(1:3,2,a)) enddo activeSystems enddo activeFamilies @@ -2693,7 +2685,9 @@ function buildCoordinateSystem(active,maximum,system,structure,cOverA) end function buildCoordinateSystem !-------------------------------------------------------------------------------------------------- -!> @brief xxx +!> @brief Helper function to define transformation systems +! Needed for Schmid_trans + C66_trans +! ToDo: completely untested and uncommented !-------------------------------------------------------------------------------------------------- subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) use math, only: & @@ -2728,7 +2722,7 @@ subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) i if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' - + if (present(a_fcc) .and. present(a_bcc)) then ! fcc -> bcc transformation if ( a_fcc <= 0.0_pReal .or. a_bcc <= 0.0_pReal) print*, 'mist' do i = 1_pInt,sum(Ntrans) @@ -2738,7 +2732,7 @@ subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) lattice_fccTobcc_bainRot(4,i)*INRAD) x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) + z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) U = (a_bcc/a_fcc)*math_tensorproduct33(x,x) & + (a_bcc/a_fcc)*math_tensorproduct33(y,y) * sqrt(2.0_pReal) & @@ -2763,7 +2757,7 @@ subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) 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 enddo endif - + end subroutine lattice_Trans end module lattice From cb28d10d79d38694348e416f8fdc0f0d8ba70edb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 12 Dec 2018 06:40:57 +0100 Subject: [PATCH 105/372] dummy structure to write plasticity results --- src/constitutive.f90 | 16 ++++++++++++- src/plastic_phenopowerlaw.f90 | 11 ++++++++- src/results.f90 | 42 +++++------------------------------ 3 files changed, 30 insertions(+), 39 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index cbb072471..61bb55542 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1182,9 +1182,23 @@ end function constitutive_postResults !-------------------------------------------------------------------------------------------------- -!> @brief contains the constitutive equation for calculating the velocity gradient +!> @brief writes constitutive results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine constitutive_results() + use material, only: & + PLASTICITY_ISOTROPIC_ID, & + PLASTICITY_PHENOPOWERLAW_ID, & + PLASTICITY_KINEHARDENING_ID, & + PLASTICITY_DISLOTWIN_ID, & + PLASTICITY_DISLOUCLA_ID, & + PLASTICITY_NONLOCAL_ID +#if defined(PETSc) || defined(DAMASKHDF5) + use plastic_phenopowerlaw, only: & + plastic_phenopowerlaw_results + + call plastic_phenopowerlaw_results +#endif + end subroutine constitutive_results diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 57d48d109..ebfab0560 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -99,7 +99,8 @@ module plastic_phenopowerlaw plastic_phenopowerlaw_init, & plastic_phenopowerlaw_LpAndItsTangent, & plastic_phenopowerlaw_dotState, & - plastic_phenopowerlaw_postResults + plastic_phenopowerlaw_postResults, & + plastic_phenopowerlaw_results contains @@ -745,4 +746,12 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) end function plastic_phenopowerlaw_postResults +!-------------------------------------------------------------------------------------------------- +!> @brief writes results to HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_results() +#if defined(PETSc) || defined(DAMASKHDF5) +#endif +end subroutine plastic_phenopowerlaw_results + end module plastic_phenopowerlaw diff --git a/src/results.f90 b/src/results.f90 index ae78ab8c1..aff53b1ba 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -33,7 +33,7 @@ module results HDF5_mappingCells, & results_addGroup, & results_openGroup, & - HDF5_writeVectorDataset, & + results_writeVectorDataset, & HDF5_writeScalarDataset, & HDF5_writeTensorDataset, & HDF5_removeLink @@ -988,16 +988,16 @@ subroutine HDF5_addTensor3DDataset(group,Nnodes,tensorSize,label,SIunit) end subroutine HDF5_addTensor3DDataset + !-------------------------------------------------------------------------------------------------- -!> @brief creates a new vector dataset in the given group location !!!TODO: really necessary? +!> @brief creates a new vector dataset in the given group location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeVectorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) +subroutine results_writeVectorDataset(group,dataset,label,SIunit) use hdf5 implicit none integer(HID_T), intent(in) :: group character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset real(pReal), intent(in), dimension(:,:) :: dataset integer :: hdferr, vectorSize @@ -1009,43 +1009,11 @@ subroutine HDF5_writeVectorDataset(group,dataset,label,SIunit,dataspace_size,mpi if(any(shape(dataset) == 0)) return vectorSize = size(dataset,1) - - call HDF5_addVectorDataset(group,dataspace_size,vectorSize,label,SIunit) ! here nNodes need to be global call h5dopen_f(group, label, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dopen_f') - ! Define and select hyperslabs - counter(1) = vectorSize ! how big i am - counter(2) = size(dataset,2) - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = mpiOffset - call h5screate_simple_f(2, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([vectorSize, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - -end subroutine HDF5_writeVectorDataset +end subroutine results_writeVectorDataset !-------------------------------------------------------------------------------------------------- !> @brief creates a new tensor dataset in the given group location From fd2d4d856bdca634111370c9537eed4ae8e19643 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 12 Dec 2018 07:45:20 +0100 Subject: [PATCH 106/372] cleaned + suggested structure to write data --- src/CPFEM2.f90 | 3 +- src/HDF5_utilities.f90 | 26 +++- src/constitutive.f90 | 19 ++- src/plastic_phenopowerlaw.f90 | 23 ++- src/results.f90 | 267 ++-------------------------------- 5 files changed, 78 insertions(+), 260 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 731fcf231..e22909231 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -331,7 +331,8 @@ subroutine CPFEM_results(inc) call results_openJobFile write(incChar,*) inc - call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') call constitutive_results() call results_closeJobFile diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 144bc9098..32747218c 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -13,7 +13,7 @@ module HDF5_utilities #endif implicit none - private + public integer(pInt), parameter, private :: & HDF5_ERR_TYPE = 4_pInt !< kind of the integer return in the HDF5 library @@ -71,7 +71,8 @@ module HDF5_utilities HDF5_openGroup, & HDF5_addGroup, & HDF5_read, & - HDF5_write + HDF5_write, & + HDF5_setLink contains subroutine HDF5_utilities_init @@ -304,7 +305,28 @@ subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) end subroutine HDF5_addIntegerAttribute +!-------------------------------------------------------------------------------------------------- +!> @brief set link to object in results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_setLink(fileHandle,path,link) + use hdf5 + implicit none + character(len=*), intent(in) :: path, link + integer(HID_T), intent(in) :: fileHandle + integer(HDF5_ERR_TYPE) :: hdferr + logical :: linkExists + + call h5lexists_f(fileHandle, link,linkExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link)//')') + if (linkExists) then + call h5ldelete_f(fileHandle,link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link)//')') + endif + call h5lcreate_soft_f(path, fileHandle, link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(path)//' '//trim(link)//')') + +end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 1 dimensions diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 61bb55542..db90bfc20 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1193,10 +1193,25 @@ subroutine constitutive_results() PLASTICITY_DISLOUCLA_ID, & PLASTICITY_NONLOCAL_ID #if defined(PETSc) || defined(DAMASKHDF5) + use results + use HDF5_utilities + use config, only: & + config_name_phase => phase_name ! anticipate logical name + use material, only: & + material_phase_plasticity_type => phase_plasticity use plastic_phenopowerlaw, only: & plastic_phenopowerlaw_results - - call plastic_phenopowerlaw_results + + implicit none + integer(pInt) :: p + call HDF5_closeGroup(results_addGroup('current/phase')) + do p=1,size(config_name_phase) + call HDF5_closeGroup(results_addGroup('current/phase/'//trim(config_name_phase(p)))) + if (material_phase_plasticity_type(p) == PLASTICITY_PHENOPOWERLAW_ID) then + call plastic_phenopowerlaw_results(p,'current/phase/'//trim(config_name_phase(p))) + endif + enddo + #endif diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index ebfab0560..677d2872c 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -749,8 +749,29 @@ end function plastic_phenopowerlaw_postResults !-------------------------------------------------------------------------------------------------- !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- -subroutine plastic_phenopowerlaw_results() +subroutine plastic_phenopowerlaw_results(instance,group) #if defined(PETSc) || defined(DAMASKHDF5) + use results + + implicit none + integer(pInt), intent(in) :: instance + character(len=*) :: group + integer(pInt) :: o + + associate(prm => param(instance), stt => state(instance)) + outputsLoop: do o = 1_pInt,size(prm%outputID) + select case(prm%outputID(o)) + case (resistance_slip_ID) + call results_writeVectorDataset(group,stt%xi_slip,'xi_slip','Pa') + case (accumulatedshear_slip_ID) + call results_writeVectorDataset(group,stt%gamma_slip,'gamma_slip','1/s') + end select + enddo outputsLoop + end associate + !results_writeVectorDataset +#else + integer(pInt), intent(in) :: instance + character(len=*) :: group #endif end subroutine plastic_phenopowerlaw_results diff --git a/src/results.f90 b/src/results.f90 index aff53b1ba..5fe35f0ee 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -34,8 +34,7 @@ module results results_addGroup, & results_openGroup, & results_writeVectorDataset, & - HDF5_writeScalarDataset, & - HDF5_writeTensorDataset, & + results_setLink, & HDF5_removeLink contains @@ -116,24 +115,16 @@ end function results_addGroup !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- -subroutine HDF5_setLink(path,link) - use hdf5 +subroutine results_setLink(path,link) + use hdf5_utilities, only: & + HDF5_setLink implicit none character(len=*), intent(in) :: path, link - integer :: hdferr - logical :: linkExists - call h5lexists_f(resultsFile, link,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link)//')') - if (linkExists) then - call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link)//')') - endif - call h5lcreate_soft_f(path, resultsFile, link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(path)//' '//trim(link)//')') + call HDF5_setLink(resultsFile,path,link) -end subroutine HDF5_setLink +end subroutine results_setLink !-------------------------------------------------------------------------------------------------- !> @brief remove link to an object @@ -952,253 +943,21 @@ subroutine HDF5_mappingCells(mapping) end subroutine HDF5_mappingCells -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new 3D Tensor dataset in the given group location !!!TODO: really necessary? -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addTensor3DDataset(group,Nnodes,tensorSize,label,SIunit) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: Nnodes, tensorSize - character(len=*), intent(in) :: SIunit, label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - integer(HSIZE_T), dimension(3) :: dataShape - - dataShape = int([tensorSize,tensorSize,Nnodes], HSIZE_T) - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(3, dataShape, space_id, hdferr, dataShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addTensor3DDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addTensor3DDataset - - !-------------------------------------------------------------------------------------------------- !> @brief creates a new vector dataset in the given group location !-------------------------------------------------------------------------------------------------- subroutine results_writeVectorDataset(group,dataset,label,SIunit) - use hdf5 implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - real(pReal), intent(in), dimension(:,:) :: dataset - - integer :: hdferr, vectorSize - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(2) :: counter - integer(HSSIZE_T), dimension(2) :: fileOffset - - if(any(shape(dataset) == 0)) return - - vectorSize = size(dataset,1) - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeVectorDataset: h5dopen_f') - + character(len=*), intent(in) :: SIunit,label,group + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + call HDF5_write(dataset,groupHandle,label) + call HDF5_closeGroup(groupHandle) end subroutine results_writeVectorDataset -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new tensor dataset in the given group location -! by default, a 3x3 tensor is assumed !!!TODO: really necessary? -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeTensorDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset - real(pReal), intent(in), dimension(:,:,:) :: dataset - - integer :: hdferr, tensorSize - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(3) :: counter - integer(HSSIZE_T), dimension(3) :: fileOffset - - if(any(shape(dataset) == 0)) return - - tensorSize = size(dataset,1) - - call HDF5_addTensor3DDataset(group,dataspace_size,tensorSize,label,SIunit) - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dopen_f') - - ! Define and select hyperslabs - counter(1) = tensorSize ! how big i am - counter(2) = tensorSize - counter(3) = size(dataset,3) - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = 0 - fileOffset(3) = mpiOffset - - call h5screate_simple_f(3, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([tensorSize, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeTensorDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - - end subroutine HDF5_writeTensorDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new vector dataset to the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addVectorDataset(group,nnodes,vectorSize,label,SIunit) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: nnodes,vectorSize - character(len=*), intent(in) :: SIunit,label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(2, int([vectorSize,Nnodes],HSIZE_T), space_id, hdferr, & - int([vectorSize,Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label), H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addVectorDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addVectorDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief writes to a new scalar dataset in the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_writeScalarDataset(group,dataset,label,SIunit,dataspace_size,mpiOffset) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - character(len=*), intent(in) :: SIunit,label - integer(pInt), intent(in) :: dataspace_size, mpiOffset - real(pReal), intent(in), dimension(:) :: dataset - - integer :: hdferr, nNodes - integer(HID_T) :: dset_id, space_id, memspace, plist_id - - integer(HSIZE_T), dimension(1) :: counter - integer(HSIZE_T), dimension(1) :: fileOffset - - nNodes = size(dataset) - if (nNodes < 1) return - - call HDF5_addScalarDataset(group,dataspace_size,label,SIunit) - call h5dopen_f(group, label, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dopen_f') - - ! Define and select hyperslabs - counter = size(dataset) ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5sselect_hyperslab_f') - - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5pset_dxpl_mpio_f') -#endif - - ! Write the dataset collectively - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE, dataset, int([dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeScalarDataset: h5dwrite_f') - - call h5sclose_f(space_id, hdferr) - call h5sclose_f(memspace, hdferr) - call h5dclose_f(dset_id, hdferr) - call h5pclose_f(plist_id, hdferr) - -end subroutine HDF5_writeScalarDataset - -!-------------------------------------------------------------------------------------------------- -!> @brief adds a new scalar dataset to the given group location -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_addScalarDataset(group,nnodes,label,SIunit) - use hdf5 - - implicit none - integer(HID_T), intent(in) :: group - integer(pInt), intent(in) :: nnodes - character(len=*), intent(in) :: SIunit,label - - integer :: hdferr - integer(HID_T) :: space_id, dset_id - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & - int([Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dcreate_f') - call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dclose_f') - call h5sclose_f(space_id, hdferr) - -end subroutine HDF5_addScalarDataset end module results From dfafddec57b329c23bd13da9868f526220b3b275 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 06:59:56 +0100 Subject: [PATCH 107/372] simplifying --- src/plastic_kinematichardening.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 590267890..8fde0e54e 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -930,31 +930,31 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,ph,instance,of) - + associate( prm => paramNew(instance), stt => state(instance)) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) - select case(param(instance)%outputID(o)) + select case(prm%outputID(o)) case (crss_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%crss(:,of) + postResults(c+1_pInt:c+nSlip) = stt%crss(:,of) c = c + nSlip case(crss_back_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%crss_back(:,of) + postResults(c+1_pInt:c+nSlip) = stt%crss_back(:,of) c = c + nSlip case (sense_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%sense(:,of) + postResults(c+1_pInt:c+nSlip) = stt%sense(:,of) c = c + nSlip case (chi0_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%chi0(:,of) + postResults(c+1_pInt:c+nSlip) = stt%chi0(:,of) c = c + nSlip case (gamma0_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%gamma0(:,of) + postResults(c+1_pInt:c+nSlip) = stt%gamma0(:,of) c = c + nSlip case (accshear_ID) - postResults(c+1_pInt:c+nSlip) = state(instance)%accshear(:,of) + postResults(c+1_pInt:c+nSlip) = stt%accshear(:,of) c = c + nSlip case (shearrate_ID) @@ -975,6 +975,7 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) end select enddo outputsLoop + end associate end function plastic_kinehardening_postResults @@ -984,8 +985,7 @@ end function plastic_kinehardening_postResults !> @details: Shear rates are calculated only optionally. NOTE: Against the common convention, the !> result (i.e. intent(out)) variables are the last to have the optional arguments at the end !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg, & - dgdot_dtau_pos,dgdot_dtau_neg) +pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) use prec, only: & dNeq0 use math, only: & From 6b5131e0f3ac494a198ff1d04b8cd128ad3f413d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 07:06:12 +0100 Subject: [PATCH 108/372] no need to have as a separate state --- src/plastic_kinematichardening.f90 | 39 +++++++++++++----------------- 1 file changed, 17 insertions(+), 22 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 8fde0e54e..bfb80cd7a 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -87,8 +87,6 @@ module plastic_kinehardening gamma0, & !< accumulated shear at last switch of stress sense accshear !< accumulated (absolute) shear - real(pReal), pointer, dimension(:) :: & !< scalars along NipcMyInstance - sumGamma !< accumulated shear across all systems end type type(tParameters), dimension(:), allocatable, private :: & @@ -258,11 +256,11 @@ subroutine plastic_kinehardening_init(fileUnit) prm%crss0 = config_phase(p)%getFloats('crss0', requiredShape=shape(prm%Nslip)) prm%tau1 = config_phase(p)%getFloats('tau1', requiredShape=shape(prm%Nslip)) - prm%tau1_b = config_phase(p)%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) - prm%theta0 = config_phase(p)%getFloats('theta0', requiredShape=shape(prm%Nslip)) - prm%theta1 = config_phase(p)%getFloats('theta1', requiredShape=shape(prm%Nslip)) - prm%theta0_b = config_phase(p)%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) - prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + prm%tau1_b = config_phase(p)%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) + prm%theta0 = config_phase(p)%getFloats('theta0', requiredShape=shape(prm%Nslip)) + prm%theta1 = config_phase(p)%getFloats('theta1', requiredShape=shape(prm%Nslip)) + prm%theta0_b = config_phase(p)%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) + prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) prm%gdot0 = config_phase(p)%getFloat('gdot0') @@ -324,8 +322,7 @@ param(instance)%outputID = prm%outputID ! allocate state arrays sizeDotState = nSlip & !< crss + nSlip & !< crss_back - + nSlip & !< accumulated (absolute) shear - + 1_pInt !< sum(gamma) + + nSlip !< accumulated (absolute) shear sizeDeltaState = nSlip & !< sense of acting shear stress (-1 or +1) + nSlip & !< backstress at last switch of stress sense @@ -362,13 +359,6 @@ param(instance)%outputID = prm%outputID dot%accshear => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolShear -! ............................................. - startIndex = endIndex + 1_pInt - endIndex = endIndex + 1_pInt - stt%sumGamma => plasticState(p)%state (startIndex ,1:NipcMyPhase) - dot%sumGamma => plasticState(p)%dotState (startIndex-o ,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex-o:endIndex-o) =prm%aTolShear - !---------------------------------------------------------------------------------------------- !locally define deltaState alias o = endIndex @@ -846,16 +836,22 @@ subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & gdot_pos,gdot_neg, & tau_pos,tau_neg + real(pReal) :: & + sumGamma of = phasememberAt(ipc,ip,el) ph = phaseAt(ipc,ip,el) instance = phase_plasticityInstance(ph) nSlip = plastic_kinehardening_totalNslip(instance) - - dotState(instance)%sumGamma(of) = 0.0_pReal + + associate( prm => paramNew(instance), stt => state(instance), dot => dotState(instance)) + call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,ph,instance,of) + + dot%accshear(:,of) = abs(gdot_pos+gdot_neg) + sumGamma = sum(stt%accshear(:,of)) j = 0_pInt slipFamilies: do f = 1_pInt,lattice_maxNslipFamily @@ -865,8 +861,8 @@ subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) dot_product(param(instance)%hardeningMatrix_SlipSlip(j,1:nSlip),abs(gdot_pos+gdot_neg)) * & ( param(instance)%theta1(f) + & (param(instance)%theta0(f) - param(instance)%theta1(f) & - + param(instance)%theta0(f)*param(instance)%theta1(f)*state(instance)%sumGamma(of)/param(instance)%tau1(f)) & - *exp(-state(instance)%sumGamma(of)*param(instance)%theta0(f)/param(instance)%tau1(f)) & ! V term depending on the harding law + + param(instance)%theta0(f)*param(instance)%theta1(f)*sumGamma/param(instance)%tau1(f)) & + *exp(-sumGamma*param(instance)%theta0(f)/param(instance)%tau1(f)) & ! V term depending on the harding law ) dotState(instance)%crss_back(j,of) = & ! evolution of back stress resistance j state(instance)%sense(j,of)*abs(gdot_pos(j)+gdot_neg(j)) * & @@ -878,10 +874,9 @@ subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) *param(instance)%theta0_b(f)/(param(instance)%tau1_b(f)+state(instance)%chi0(j,of))) & ) ! V term depending on the harding law for back stress - dotState(instance)%accshear(j,of) = abs(gdot_pos(j)+gdot_neg(j)) - dotState(instance)%sumGamma(of) = dotState(instance)%sumGamma(of) + dotState(instance)%accshear(j,of) enddo slipSystems enddo slipFamilies + end associate end subroutine plastic_kinehardening_dotState From a7351deab073ee36dd3fe7ed8193a3e48f3fc5b8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 07:31:56 +0100 Subject: [PATCH 109/372] simplified --- src/plastic_kinematichardening.f90 | 200 ++++++++++------------------- 1 file changed, 66 insertions(+), 134 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index bfb80cd7a..e5b6547cf 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -59,9 +59,9 @@ module plastic_kinehardening theta1_b, & !< asymptotic hardening rate of back stress for each slip > tau1, & tau1_b, & - interaction_slipslip, & !< latent hardening matrix nonSchmidCoeff - + real(pReal), dimension(:,:), allocatable, private :: & + interaction_slipslip !< latent hardening matrix real(pReal), allocatable, dimension(:,:,:) :: & Schmid_slip, & Schmid_twin, & @@ -253,6 +253,9 @@ subroutine plastic_kinehardening_init(fileUnit) prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip endif + prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & + config_phase(p)%getFloats('interaction_slipslip'), & + structure(1:3)) prm%crss0 = config_phase(p)%getFloats('crss0', requiredShape=shape(prm%Nslip)) prm%tau1 = config_phase(p)%getFloats('tau1', requiredShape=shape(prm%Nslip)) @@ -262,15 +265,20 @@ subroutine plastic_kinehardening_init(fileUnit) prm%theta0_b = config_phase(p)%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + ! expand: family => system + prm%crss0 = math_expand(prm%crss0, prm%Nslip) + prm%tau1 = math_expand(prm%tau1,prm%Nslip) + prm%tau1_b = math_expand(prm%tau1_b, prm%Nslip) + prm%theta0 = math_expand(prm%theta0,prm%Nslip) + prm%theta1 = math_expand(prm%theta1,prm%Nslip) + prm%theta0_b = math_expand(prm%theta0_b,prm%Nslip) + prm%theta1_b = math_expand(prm%theta1_b,prm%Nslip) prm%gdot0 = config_phase(p)%getFloat('gdot0') - prm%n_slip = config_phase(p)%getFloat('n_slip') + prm%n_slip = config_phase(p)%getFloat('n_slip') - !prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - ! config_phase(p)%getFloats('interaction_slipslip'), & - ! structure(1:3)) endif slipActive @@ -414,7 +422,6 @@ param(instance)%outputID = prm%outputID allocate(param(instance)%theta1 (Nchunks_SlipFamilies), source=0.0_pReal) allocate(param(instance)%theta0_b(Nchunks_SlipFamilies), source=0.0_pReal) allocate(param(instance)%theta1_b(Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%interaction_slipslip(Nchunks_SlipSlip), source=0.0_pReal) allocate(param(instance)%nonSchmidCoeff(Nchunks_nonSchmid), source=0.0_pReal) if(allocated(tempPerSlip)) deallocate(tempPerSlip) allocate(tempPerSlip(Nchunks_SlipFamilies)) @@ -464,12 +471,6 @@ param(instance)%outputID = prm%outputID !-------------------------------------------------------------------------------------------------- ! parameters depending on number of interactions - case ('interaction_slipslip') - if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & - call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') - do j = 1_pInt, Nchunks_SlipSlip - param(instance)%interaction_slipslip(j) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo case ('nonschmidcoeff') if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') @@ -529,20 +530,6 @@ param(instance)%outputID = prm%outputID plasticState(phase)%accumulatedSlip => & plasticState(phase)%state(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) - allocate(param(instance)%hardeningMatrix_SlipSlip(nSlip,nSlip), source=0.0_pReal) - do f = 1_pInt,lattice_maxNslipFamily ! >>> interaction slip -- X - index_myFamily = sum(plastic_kinehardening_Nslip(1:f-1_pInt,instance)) - do j = 1_pInt,plastic_kinehardening_Nslip(f,instance) ! loop over (active) systems in my family (slip) - do o = 1_pInt,lattice_maxNslipFamily - index_otherFamily = sum(plastic_kinehardening_Nslip(1:o-1_pInt,instance)) - do k = 1_pInt,plastic_kinehardening_Nslip(o,instance) ! loop over (active) systems in other family (slip) - param(instance)%hardeningMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k) = & - param(instance)%interaction_SlipSlip(lattice_interactionSlipSlip( & - sum(lattice_NslipSystem(1:f-1,phase))+j, & - sum(lattice_NslipSystem(1:o-1,phase))+k, & - phase)) - enddo; enddo - enddo; enddo endindex = 0_pInt o = endIndex ! offset of dotstate index relative to state index @@ -626,23 +613,6 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & Mp,ipc,ip,el) use prec, only: & dNeq0 - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelExtensive, & - debug_levelSelective, & - debug_e, & - debug_i, & - debug_g - use math, only: & - math_Plain3333to99, & - math_Mandel6to33, & - math_transpose33 - use lattice, only: & - lattice_Sslip, & !< schmid matrix - lattice_maxNslipFamily, & - lattice_NslipSystem, & - lattice_NnonSchmid use material, only: & phaseAt, phasememberAt, & phase_plasticityInstance @@ -662,7 +632,6 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & integer(pInt) :: & instance, & - index_myFamily, & f,i,j,k,l,m,n, & of, & ph @@ -672,59 +641,41 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & tau_pos,tau_neg real(pReal) :: & dgdot_dtau_pos,dgdot_dtau_neg - real(pReal), dimension(3,3,2) :: & - nonSchmid_tensor ph = phaseAt(ipc,ip,el) !< figures phase for each material point of = phasememberAt(ipc,ip,el) !< index of the positions of each constituent of material point, phasememberAt is a function in material that helps figure them out instance = phase_plasticityInstance(ph) + associate(prm => paramNew(instance), stt => state(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,ph,instance,of) + tau_pos = tau_pos - stt%crss_back(:,of) + tau_neg = tau_neg - stt%crss_back(:,of) + do j = 1_pInt, prm%totalNslip - j = 0_pInt ! reading and marking the starting index for each slip family - slipFamilies: do f = 1_pInt,lattice_maxNslipFamily - index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family - slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) - j = j + 1_pInt - - ! build nonSchmid tensor - nonSchmid_tensor(1:3,1:3,1) = lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) - nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,1) - do k = 1,lattice_NnonSchmid(ph) - nonSchmid_tensor(1:3,1:3,1) = & - nonSchmid_tensor(1:3,1:3,1) + param(instance)%nonSchmidCoeff(k) * & - lattice_Sslip(1:3,1:3,2*k,index_myFamily+i,ph) - nonSchmid_tensor(1:3,1:3,2) = & - nonSchmid_tensor(1:3,1:3,2) + param(instance)%nonSchmidCoeff(k) * & - lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph) - enddo - - Lp = Lp + (gdot_pos(j)+gdot_neg(j))*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) ! sum of all gdot*SchmidTensor gives Lp + Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) ! sum of all gdot*SchmidTensor gives Lp ! Calculation of the tangent of Lp ! sensitivity of Lp if (dNeq0(gdot_pos(j))) then - dgdot_dtau_pos = gdot_pos(j)*param(instance)%n_slip/(tau_pos(j)-state(instance)%crss_back(j,of)) + dgdot_dtau_pos = gdot_pos(j)*param(instance)%n_slip/tau_pos(j) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = & - dLp_dMp(k,l,m,n) + dgdot_dtau_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & - nonSchmid_tensor(m,n,1) + dLp_dMp(k,l,m,n) + dgdot_dtau_pos*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) endif if (dNeq0(gdot_neg(j))) then - dgdot_dtau_neg = gdot_neg(j)*param(instance)%n_slip/(tau_neg(j)-state(instance)%crss_back(j,of)) + dgdot_dtau_neg = gdot_neg(j)*param(instance)%n_slip/tau_neg(j) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = & - dLp_dMp(k,l,m,n) + dgdot_dtau_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & - nonSchmid_tensor(m,n,2) + dLp_dMp(k,l,m,n) + dgdot_dtau_neg*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) endif - enddo slipSystems - enddo slipFamilies + enddo +end associate end subroutine plastic_kinehardening_LpAndItsTangent @@ -735,14 +686,6 @@ subroutine plastic_kinehardening_deltaState(Mp,ipc,ip,el) use prec, only: & dNeq, & dEq0 - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelExtensive, & - debug_levelSelective, & - debug_e, & - debug_i, & - debug_g use material, only: & phaseAt, & phasememberAt, & @@ -776,33 +719,32 @@ subroutine plastic_kinehardening_deltaState(Mp,ipc,ip,el) 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 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then - write(6,'(a)') '======= kinehardening delta state =======' - endif +! if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & +! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & +! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then +! write(6,'(a)') '======= kinehardening delta state =======' +! endif #endif + +#ifdef DEBUG +! if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & +! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & +! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then +! write(6,'(i2,1x,f7.4,1x,f7.4)') j,sense(j),state(instance)%sense(j,of) +! endif +#endif !-------------------------------------------------------------------------------------------------- ! switch in sense of shear? - do j = 1,plastic_kinehardening_totalNslip(instance) -#ifdef DEBUG - if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then - write(6,'(i2,1x,f7.4,1x,f7.4)') j,sense(j),state(instance)%sense(j,of) - endif -#endif - if (dNeq(sense(j),state(instance)%sense(j,of),0.1_pReal)) then - deltaState(instance)%sense (j,of) = sense(j) - state(instance)%sense(j,of) ! switch sense - deltaState(instance)%chi0 (j,of) = abs(state(instance)%crss_back(j,of)) - state(instance)%chi0(j,of) ! remember current backstress magnitude - deltaState(instance)%gamma0(j,of) = state(instance)%accshear(j,of) - state(instance)%gamma0(j,of) ! remember current accumulated shear - else - deltaState(instance)%sense (j,of) = 0.0_pReal ! no change - deltaState(instance)%chi0 (j,of) = 0.0_pReal - deltaState(instance)%gamma0(j,of) = 0.0_pReal - endif - enddo + where(dNeq(sense,state(instance)%sense(:,of),0.1_pReal)) + deltaState(instance)%sense (:,of) = sense - state(instance)%sense(:,of) ! switch sense + deltaState(instance)%chi0 (:,of) = abs(state(instance)%crss_back(:,of)) - state(instance)%chi0(:,of) ! remember current backstress magnitude + deltaState(instance)%gamma0(:,of) = state(instance)%accshear(:,of) - state(instance)%gamma0(:,of) ! remember current accumulated shear + else where + deltaState(instance)%sense (:,of) = 0.0_pReal ! no change + deltaState(instance)%chi0 (:,of) = 0.0_pReal + deltaState(instance)%gamma0(:,of) = 0.0_pReal + end where end subroutine plastic_kinehardening_deltaState @@ -852,30 +794,26 @@ subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) - - j = 0_pInt - slipFamilies: do f = 1_pInt,lattice_maxNslipFamily - slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) - j = j+1_pInt - dotState(instance)%crss(j,of) = & ! evolution of slip resistance j - dot_product(param(instance)%hardeningMatrix_SlipSlip(j,1:nSlip),abs(gdot_pos+gdot_neg)) * & - ( param(instance)%theta1(f) + & - (param(instance)%theta0(f) - param(instance)%theta1(f) & - + param(instance)%theta0(f)*param(instance)%theta1(f)*sumGamma/param(instance)%tau1(f)) & - *exp(-sumGamma*param(instance)%theta0(f)/param(instance)%tau1(f)) & ! V term depending on the harding law + + do j = 1_pInt, prm%totalNslip + dot%crss(j,of) = & ! evolution of slip resistance j + dot_product(prm%interaction_SlipSlip(j,:),abs(gdot_pos+gdot_neg)) * & + ( prm%theta1(j) + & + (prm%theta0(j) - prm%theta1(j) & + + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)) & + *exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & ! V term depending on the harding law ) - dotState(instance)%crss_back(j,of) = & ! evolution of back stress resistance j - state(instance)%sense(j,of)*abs(gdot_pos(j)+gdot_neg(j)) * & - ( param(instance)%theta1_b(f) + & - (param(instance)%theta0_b(f) - param(instance)%theta1_b(f) & - + param(instance)%theta0_b(f)*param(instance)%theta1_b(f)/(param(instance)%tau1_b(f)+state(instance)%chi0(j,of)) & - *(state(instance)%accshear(j,of)-state(instance)%gamma0(j,of))) & + dot%crss_back(j,of) = & ! evolution of back stress resistance j + stt%sense(j,of)*abs(gdot_pos(j)+gdot_neg(j)) * & + ( prm%theta1_b(j) + & + (prm%theta0_b(j) - prm%theta1_b(j) & + + prm%theta0_b(j)*prm%theta1_b(j)/(prm%tau1_b(j)+stt%chi0(j,of)) & + *(stt%accshear(j,of)-state(instance)%gamma0(j,of))) & *exp(-(state(instance)%accshear(j,of)-state(instance)%gamma0(j,of)) & - *param(instance)%theta0_b(f)/(param(instance)%tau1_b(f)+state(instance)%chi0(j,of))) & + *prm%theta0_b(j)/(prm%tau1_b(j)+state(instance)%chi0(j,of))) & ) ! V term depending on the harding law for back stress - enddo slipSystems - enddo slipFamilies + enddo end associate end subroutine plastic_kinehardening_dotState @@ -957,15 +895,9 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) c = c + nSlip case (resolvedstress_ID) - j = 0_pInt - slipFamilies: do f = 1_pInt,lattice_maxNslipFamily - index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family - slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) - j = j + 1_pInt - postResults(c+j) = & - math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph)) - enddo slipSystems - enddo slipFamilies + do j = 1_pInt, prm%totalNslip + postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) + enddo c = c + nSlip end select From d99778dd9625b5b0f47352d9c574935645ed565f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 08:43:26 +0100 Subject: [PATCH 110/372] further cleaning --- src/plastic_kinematichardening.f90 | 34 +++++++----------------------- 1 file changed, 8 insertions(+), 26 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index e5b6547cf..6a2fd97dd 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -416,12 +416,6 @@ param(instance)%outputID = prm%outputID Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) Nchunks_nonSchmid = lattice_NnonSchmid(phase) allocate(param(instance)%crss0 (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%tau1 (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%tau1_b (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%theta0 (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%theta1 (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%theta0_b(Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%theta1_b(Nchunks_SlipFamilies), source=0.0_pReal) allocate(param(instance)%nonSchmidCoeff(Nchunks_nonSchmid), source=0.0_pReal) if(allocated(tempPerSlip)) deallocate(tempPerSlip) allocate(tempPerSlip(Nchunks_SlipFamilies)) @@ -455,18 +449,6 @@ param(instance)%outputID = prm%outputID select case(tag) case ('crss0') param(instance)%crss0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('tau1') - param(instance)%tau1(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('tau1_b') - param(instance)%tau1_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('theta0') - param(instance)%theta0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('theta1') - param(instance)%theta1(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('theta0_b') - param(instance)%theta0_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - case ('theta1_b') - param(instance)%theta1_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) end select !-------------------------------------------------------------------------------------------------- @@ -510,14 +492,14 @@ param(instance)%outputID = prm%outputID !-------------------------------------------------------------------------------------------------- ! sanity checks - if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - .and. param(instance)%crss0 (1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' - if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - .and. param(instance)%tau1 (1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' - if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' - if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%crss0 (1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%tau1 (1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' + ! if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + ! if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (extmsg /= '') then extmsg = trim(extmsg)//' ('//PLASTICITY_KINEHARDENING_label//')' ! prepare error message identifier call IO_error(211_pInt,ip=instance,ext_msg=extmsg) From 98cc79d629ced8e7e8c11ab658525a4364544e44 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 09:08:18 +0100 Subject: [PATCH 111/372] ph not needed any more --- src/plastic_kinematichardening.f90 | 64 +++++++++--------------------- 1 file changed, 18 insertions(+), 46 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 6a2fd97dd..582511064 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -450,22 +450,7 @@ param(instance)%outputID = prm%outputID case ('crss0') param(instance)%crss0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) end select - -!-------------------------------------------------------------------------------------------------- -! parameters depending on number of interactions - case ('nonschmidcoeff') - if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & - call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') - do j = 1_pInt,Nchunks_nonSchmid - param(instance)%nonSchmidCoeff(j) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo -!-------------------------------------------------------------------------------------------------- - case ('gdot0') - param(instance)%gdot0 = IO_floatValue(line,chunkPos,2_pInt) - - case ('n_slip') - param(instance)%n_slip = IO_floatValue(line,chunkPos,2_pInt) - + case default end select @@ -532,7 +517,7 @@ end subroutine plastic_kinehardening_init !> @brief calculation of shear rates (\dot \gamma) !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,ph,instance,of) + Mp,instance,of) use math use lattice, only: & @@ -545,7 +530,6 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & real(pReal), dimension(3,3), intent(in) :: & Mp integer(pInt), intent(in) :: & - ph, & !< phase ID instance, & !< instance of that phase of !< index of phaseMember real(pReal), dimension(plastic_kinehardening_totalNslip(instance)), intent(out) :: & @@ -557,34 +541,22 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & integer(pInt) :: & index_myFamily, & f,i,j,k + associate(prm => paramNew(instance), stt => state(instance)) + do i = 1_pInt, prm%totalNslip + tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) + tau_neg(i) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) + enddo - - j = 0_pInt - slipFamilies: do f = 1_pInt,lattice_maxNslipFamily - index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family - slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) - j = j + 1_pInt - tau_pos(j) = math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph)) - tau_neg(j) = tau_pos(j) - nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) - tau_pos(j) = tau_pos(j) + param(instance)%nonSchmidCoeff(k)* & - math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,2*k+0,index_myFamily+i,ph)) - tau_neg(j) = tau_neg(j) + param(instance)%nonSchmidCoeff(k)* & - math_mul33xx33(Mp,lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph)) - enddo nonSchmidSystems - enddo slipSystems - enddo slipFamilies - - gdot_pos = 0.5_pReal * param(instance)%gdot0 * & + gdot_pos = 0.5_pReal * prm%gdot0 * & (abs(tau_pos-state(instance)%crss_back(:,of))/ & - state(instance)%crss(:,of))**param(instance)%n_slip & + state(instance)%crss(:,of))**prm%n_slip & *sign(1.0_pReal,tau_pos-state(instance)%crss_back(:,of)) - gdot_neg = 0.5_pReal * param(instance)%gdot0 * & + gdot_neg = 0.5_pReal * prm%gdot0 * & (abs(tau_neg-state(instance)%crss_back(:,of))/ & - state(instance)%crss(:,of))**param(instance)%n_slip & + state(instance)%crss(:,of))**prm%n_slip & *sign(1.0_pReal,tau_neg-state(instance)%crss_back(:,of)) - +end associate end subroutine plastic_kinehardening_shearRates @@ -633,7 +605,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & dLp_dMp = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,ph,instance,of) + Mp,instance,of) tau_pos = tau_pos - stt%crss_back(:,of) tau_neg = tau_neg - stt%crss_back(:,of) @@ -643,14 +615,14 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & ! Calculation of the tangent of Lp ! sensitivity of Lp if (dNeq0(gdot_pos(j))) then - dgdot_dtau_pos = gdot_pos(j)*param(instance)%n_slip/tau_pos(j) + dgdot_dtau_pos = gdot_pos(j)*prm%n_slip/tau_pos(j) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = & dLp_dMp(k,l,m,n) + dgdot_dtau_pos*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) endif if (dNeq0(gdot_neg(j))) then - dgdot_dtau_neg = gdot_neg(j)*param(instance)%n_slip/tau_neg(j) + dgdot_dtau_neg = gdot_neg(j)*prm%n_slip/tau_neg(j) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = & dLp_dMp(k,l,m,n) + dgdot_dtau_neg*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) @@ -695,7 +667,7 @@ subroutine plastic_kinehardening_deltaState(Mp,ipc,ip,el) instance = phase_plasticityInstance(ph) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,ph,instance,of) + Mp,instance,of) sense = merge(state(instance)%sense(:,of), & ! keep existing... sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction @@ -772,7 +744,7 @@ subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,ph,instance,of) + Mp,instance,of) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) @@ -844,7 +816,7 @@ function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) c = 0_pInt call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,ph,instance,of) + Mp,instance,of) associate( prm => paramNew(instance), stt => state(instance)) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(prm%outputID(o)) From 416d3411c1e6ea4b106917dc91983c84d69ff967 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 09:34:40 +0100 Subject: [PATCH 112/372] leaner APIs --- src/constitutive.f90 | 27 +++-- src/plastic_kinematichardening.f90 | 160 +++++++++-------------------- 2 files changed, 69 insertions(+), 118 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 6fd0161f9..a8e57034b 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -516,7 +516,9 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e call plastic_phenopowerlaw_LpAndItsTangent (Lp,dLp_dMp, Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, Mp,ipc,ip,el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, Mp,instance,of) case (PLASTICITY_NONLOCAL_ID) plasticityType call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp), & @@ -918,7 +920,9 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac call plastic_phenopowerlaw_dotState(Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_dotState(Mp,ipc,ip,el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_kinehardening_dotState(Mp,instance,of) case (PLASTICITY_DISLOTWIN_ID) plasticityType call plastic_dislotwin_dotState (math_Mandel33to6(Mp),temperature(ho)%p(tme), & @@ -972,6 +976,8 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) math_Mandel33to6, & math_mul33x33 use material, only: & + phasememberAt, & + phase_plasticityInstance, & phase_plasticity, & phase_source, & phase_Nsources, & @@ -1003,19 +1009,22 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) Fe, & !< elastic deformation gradient Fi !< intermediate deformation gradient real(pReal), dimension(3,3) :: & - Mstar + Mp integer(pInt) :: & - s !< counter in source loop + s, & !< counter in source loop + instance, of - Mstar = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(S6)) + Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(S6)) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_KINEHARDENING_ID) plasticityType - call plastic_kinehardening_deltaState(Mstar,ipc,ip,el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_kinehardening_deltaState(Mp,instance,of) case (PLASTICITY_NONLOCAL_ID) plasticityType - call plastic_nonlocal_deltaState(math_Mandel33to6(Mstar),ip,el) + call plastic_nonlocal_deltaState(math_Mandel33to6(Mp),ip,el) end select plasticityType @@ -1140,8 +1149,10 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) constitutive_postResults(startPos:endPos) = & plastic_phenopowerlaw_postResults(Mp,instance,of) case (PLASTICITY_KINEHARDENING_ID) plasticityType + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) constitutive_postResults(startPos:endPos) = & - plastic_kinehardening_postResults(Mp,ipc,ip,el) + plastic_kinehardening_postResults(Mp,instance,of) case (PLASTICITY_DISLOTWIN_ID) plasticityType constitutive_postResults(startPos:endPos) = & plastic_dislotwin_postResults(S6,temperature(ho)%p(tme),ipc,ip,el) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 582511064..1c533b0b2 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -520,11 +520,6 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,instance,of) use math - use lattice, only: & - lattice_NslipSystem, & - lattice_Sslip, & - lattice_maxNslipFamily, & - lattice_NnonSchmid implicit none real(pReal), dimension(3,3), intent(in) :: & @@ -532,7 +527,7 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & integer(pInt), intent(in) :: & instance, & !< instance of that phase of !< index of phaseMember - real(pReal), dimension(plastic_kinehardening_totalNslip(instance)), intent(out) :: & + real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & gdot_pos, & !< shear rates from positive line segments gdot_neg, & !< shear rates from negative line segments tau_pos, & !< shear stress on positive line segments @@ -563,43 +558,32 @@ end subroutine plastic_kinehardening_shearRates !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp, & - Mp,ipc,ip,el) +subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) use prec, only: & dNeq0 - use material, only: & - phaseAt, phasememberAt, & - phase_plasticityInstance - + 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 - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element real(pReal), dimension(3,3), intent(in) :: & - Mp + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of integer(pInt) :: & - instance, & - f,i,j,k,l,m,n, & - of, & - ph + f,i,j,k,l,m,n + - real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(phaseAt(ipc,ip,el)))) :: & + real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & tau_pos,tau_neg real(pReal) :: & dgdot_dtau_pos,dgdot_dtau_neg - ph = phaseAt(ipc,ip,el) !< figures phase for each material point - of = phasememberAt(ipc,ip,el) !< index of the positions of each constituent of material point, phasememberAt is a function in material that helps figure them out - instance = phase_plasticityInstance(ph) - associate(prm => paramNew(instance), stt => state(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -636,35 +620,22 @@ end subroutine plastic_kinehardening_LpAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief calculates (instantaneous) incremental change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_deltaState(Mp,ipc,ip,el) +subroutine plastic_kinehardening_deltaState(Mp,instance,of) use prec, only: & dNeq, & dEq0 - use material, only: & - phaseAt, & - phasememberAt, & - phase_plasticityInstance - + implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(phaseAt(ipc,ip,el)))) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + + real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & tau_pos,tau_neg, & sense - integer(pInt) :: & - ph, & - instance, & !< instance of my instance (unique number of my constitutive model) - of, & - j !< shortcut notation for offset position in state array - - ph = phaseAt(ipc,ip,el) - of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember - instance = phase_plasticityInstance(ph) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,instance,of) @@ -707,38 +678,24 @@ end subroutine plastic_kinehardening_deltaState !-------------------------------------------------------------------------------------------------- !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_dotState(Mp,ipc,ip,el) - use lattice, only: & - lattice_maxNslipFamily - use material, only: & - material_phase, & - phaseAt, phasememberAt, & - phase_plasticityInstance +subroutine plastic_kinehardening_dotState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & - Mp + Mp !< Mandel stress integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element !< microstructure state + instance, & + of !< element !< microstructure state integer(pInt) :: & - instance,ph, & - f,i,j, & - nSlip, & - of + f,i,j - real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & tau_pos,tau_neg real(pReal) :: & sumGamma - of = phasememberAt(ipc,ip,el) - ph = phaseAt(ipc,ip,el) - instance = phase_plasticityInstance(ph) - nSlip = plastic_kinehardening_totalNslip(instance) associate( prm => paramNew(instance), stt => state(instance), dot => dotState(instance)) @@ -775,84 +732,67 @@ end subroutine plastic_kinehardening_dotState !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -function plastic_kinehardening_postResults(Mp,ipc,ip,el) result(postResults) - use math - use material, only: & - material_phase, & - phaseAt, phasememberAt, & - phase_plasticityInstance - use lattice, only: & - lattice_Sslip, & - lattice_maxNslipFamily, & - lattice_NslipSystem +function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) + use math, only: & + math_mul33xx33 implicit none real(pReal), dimension(3,3), intent(in) :: & - Mp + Mp !< Mandel stress integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element !< microstructure state + instance, & + of - real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(material_phase(ipc,ip,el))))) :: & + real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,instance))) :: & postResults integer(pInt) :: & - instance,ph, of, & - nSlip,& - o,f,i,c,j,& - index_myFamily + o,c,f,j - real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & tau_pos,tau_neg - of = phasememberAt(ipc,ip,el) - ph = phaseAt(ipc,ip,el) - instance = phase_plasticityInstance(ph) - - nSlip = plastic_kinehardening_totalNslip(instance) - postResults = 0.0_pReal c = 0_pInt call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) + Mp,instance,of) associate( prm => paramNew(instance), stt => state(instance)) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(prm%outputID(o)) case (crss_ID) - postResults(c+1_pInt:c+nSlip) = stt%crss(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%crss(:,of) + c = c + prm%totalNslip case(crss_back_ID) - postResults(c+1_pInt:c+nSlip) = stt%crss_back(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%crss_back(:,of) + c = c + prm%totalNslip case (sense_ID) - postResults(c+1_pInt:c+nSlip) = stt%sense(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) + c = c + prm%totalNslip case (chi0_ID) - postResults(c+1_pInt:c+nSlip) = stt%chi0(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%chi0(:,of) + c = c + prm%totalNslip case (gamma0_ID) - postResults(c+1_pInt:c+nSlip) = stt%gamma0(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%gamma0(:,of) + c = c + prm%totalNslip case (accshear_ID) - postResults(c+1_pInt:c+nSlip) = stt%accshear(:,of) - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear(:,of) + c = c + prm%totalNslip case (shearrate_ID) - postResults(c+1_pInt:c+nSlip) = gdot_pos+gdot_neg - c = c + nSlip + postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg + c = c + prm%totalNslip case (resolvedstress_ID) do j = 1_pInt, prm%totalNslip postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) enddo - c = c + nSlip + c = c + prm%totalNslip end select enddo outputsLoop From 20671b8ed38427ee0f41e82464549b289902c890 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 09:51:43 +0100 Subject: [PATCH 113/372] cleaning --- src/constitutive.f90 | 2 +- src/plastic_kinematichardening.f90 | 135 +++++------------------------ 2 files changed, 23 insertions(+), 114 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index a8e57034b..28d95f4ea 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -162,7 +162,7 @@ subroutine constitutive_init() if (any(phase_plasticity == PLASTICITY_NONE_ID)) call plastic_none_init if (any(phase_plasticity == PLASTICITY_ISOTROPIC_ID)) call plastic_isotropic_init if (any(phase_plasticity == PLASTICITY_PHENOPOWERLAW_ID)) call plastic_phenopowerlaw_init - if (any(phase_plasticity == PLASTICITY_KINEHARDENING_ID)) call plastic_kinehardening_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_KINEHARDENING_ID)) call plastic_kinehardening_init if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_DISLOUCLA_ID)) call plastic_disloucla_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) then diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 1c533b0b2..85daab322 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -118,7 +118,7 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_init(fileUnit) +subroutine plastic_kinehardening_init use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use prec, only: & dEq0 @@ -127,22 +127,10 @@ subroutine plastic_kinehardening_init(fileUnit) debug_constitutive,& debug_levelBasic use math, only: & - math_Mandel3333to66, & - math_Voigt66to3333, & math_expand use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & IO_error, & - IO_timeStamp, & - IO_EOF + IO_timeStamp use material, only: & phase_plasticity, & phase_plasticityInstance, & @@ -158,23 +146,19 @@ subroutine plastic_kinehardening_init(fileUnit) use lattice implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos integer(kind(undefined_ID)) :: & output_ID integer(pInt) :: & - o, i,j, k, f, p, & + o, i, p, & phase, & instance, & maxNinstance, & NipcMyPhase, & outputSize, & - Nchunks_SlipSlip = 0_pInt, Nchunks_SlipFamilies = 0_pInt, & - Nchunks_nonSchmid = 0_pInt, & - offset_slip, index_myFamily, index_otherFamily, & + offset_slip, & startIndex, endIndex, & - mySize, nSlip, nSlipFamilies, & + nSlip, & sizeDotState, & sizeState, & sizeDeltaState @@ -183,7 +167,6 @@ subroutine plastic_kinehardening_init(fileUnit) real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - real(pReal), dimension(:), allocatable :: tempPerSlip integer(kind(undefined_ID)) :: & outputID !< ID of each post result output @@ -191,7 +174,6 @@ subroutine plastic_kinehardening_init(fileUnit) outputs character(len=65536) :: & tag = '', & - line = '', & extmsg = '', & structure = '' @@ -266,7 +248,7 @@ subroutine plastic_kinehardening_init(fileUnit) prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) ! expand: family => system - prm%crss0 = math_expand(prm%crss0, prm%Nslip) + !prm%crss0 = math_expand(prm%crss0, prm%Nslip) prm%tau1 = math_expand(prm%tau1,prm%Nslip) prm%tau1_b = math_expand(prm%tau1_b, prm%Nslip) prm%theta0 = math_expand(prm%theta0,prm%Nslip) @@ -277,8 +259,6 @@ subroutine plastic_kinehardening_init(fileUnit) prm%gdot0 = config_phase(p)%getFloat('gdot0') prm%n_slip = config_phase(p)%getFloat('n_slip') - - endif slipActive @@ -394,85 +374,13 @@ param(instance)%outputID = prm%outputID end associate end do - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase - phase = phase + 1_pInt ! advance phase section counter - if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then - instance = phase_plasticityInstance(phase) ! count instances of my constitutive law - Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) ! maximum number of slip families according to lattice type of current phase - Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) - Nchunks_nonSchmid = lattice_NnonSchmid(phase) - allocate(param(instance)%crss0 (Nchunks_SlipFamilies), source=0.0_pReal) - allocate(param(instance)%nonSchmidCoeff(Nchunks_nonSchmid), source=0.0_pReal) - if(allocated(tempPerSlip)) deallocate(tempPerSlip) - allocate(tempPerSlip(Nchunks_SlipFamilies)) - endif - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - - -!-------------------------------------------------------------------------------------------------- -! parameters depending on number of slip families - case ('nslip') - if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & - call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') - if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & - call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') - Nchunks_SlipFamilies = chunkPos(1) - 1_pInt ! user specified number of (possibly) active slip families (e.g. 6 0 6 --> 3) - do j = 1_pInt, Nchunks_SlipFamilies - plastic_kinehardening_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) - enddo - - case ('crss0','tau1','tau1_b','theta0','theta1','theta0_b','theta1_b') - tempPerSlip = 0.0_pReal - do j = 1_pInt, Nchunks_SlipFamilies - if (plastic_kinehardening_Nslip(j,instance) > 0_pInt) & - tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo - select case(tag) - case ('crss0') - param(instance)%crss0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) - end select - - case default - - end select - endif; endif - enddo parsingFile !-------------------------------------------------------------------------------------------------- ! allocation of variables whose size depends on the total number of active slip systems - - - initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config myPhase2: if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then ! only consider my phase NipcMyPhase = count(material_phase == phase) ! number of IPCs containing my phase instance = phase_plasticityInstance(phase) ! which instance of my phase - plastic_kinehardening_Nslip(1:lattice_maxNslipFamily,instance) = & - min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active slip systems per family to min of available and requested - plastic_kinehardening_Nslip(1:lattice_maxNslipFamily,instance)) - - plastic_kinehardening_totalNslip(instance) = sum(plastic_kinehardening_Nslip(:,instance)) ! how many slip systems altogether - nSlipFamilies = count(plastic_kinehardening_Nslip(:,instance) > 0_pInt) - nSlip = plastic_kinehardening_totalNslip(instance) ! total number of active slip systems !-------------------------------------------------------------------------------------------------- ! sanity checks @@ -491,7 +399,7 @@ param(instance)%outputID = prm%outputID endif - offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt + offset_slip = plasticState(phase)%nSlip plasticState(phase)%slipRate => & plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) plasticState(phase)%accumulatedSlip => & @@ -502,11 +410,11 @@ param(instance)%outputID = prm%outputID o = endIndex ! offset of dotstate index relative to state index startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + paramNew(instance)%totalNslip state0 (instance)%crss => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - state0(instance)%crss = spread(math_expand(param(instance)%crss0,& - plastic_kinehardening_Nslip(:,instance)), & + state0(instance)%crss = spread(math_expand(paramNew(instance)%crss0,& + paramNew(instance)%Nslip), & 2, NipcMyPhase) endif myPhase2 enddo initializeInstances @@ -534,22 +442,25 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & tau_neg !< shear stress on negative line segments integer(pInt) :: & - index_myFamily, & - f,i,j,k + i + associate(prm => paramNew(instance), stt => state(instance)) do i = 1_pInt, prm%totalNslip tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) tau_neg(i) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) enddo + + tau_pos = tau_pos - stt%crss_back(:,of) + tau_neg = tau_neg - stt%crss_back(:,of) gdot_pos = 0.5_pReal * prm%gdot0 * & - (abs(tau_pos-state(instance)%crss_back(:,of))/ & + (abs(tau_pos)/ & state(instance)%crss(:,of))**prm%n_slip & - *sign(1.0_pReal,tau_pos-state(instance)%crss_back(:,of)) + *sign(1.0_pReal,tau_pos) gdot_neg = 0.5_pReal * prm%gdot0 * & - (abs(tau_neg-state(instance)%crss_back(:,of))/ & + (abs(tau_neg)/ & state(instance)%crss(:,of))**prm%n_slip & - *sign(1.0_pReal,tau_neg-state(instance)%crss_back(:,of)) + *sign(1.0_pReal,tau_neg) end associate end subroutine plastic_kinehardening_shearRates @@ -575,7 +486,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) of integer(pInt) :: & - f,i,j,k,l,m,n + j,k,l,m,n real(pReal), dimension(paramNew(instance)%totalNslip) :: & @@ -590,8 +501,6 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,instance,of) - tau_pos = tau_pos - stt%crss_back(:,of) - tau_neg = tau_neg - stt%crss_back(:,of) do j = 1_pInt, prm%totalNslip @@ -688,7 +597,7 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) of !< element !< microstructure state integer(pInt) :: & - f,i,j + j real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & @@ -746,7 +655,7 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,instance))) :: & postResults integer(pInt) :: & - o,c,f,j + o,c,j real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & From 3352cbac4bbb15488b4d1f1ca7cf58dbbacb4b90 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 10:51:35 +0100 Subject: [PATCH 114/372] segmentation fault expected instance but passed in phase --- src/constitutive.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index db90bfc20..f85641f8d 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1197,7 +1197,9 @@ subroutine constitutive_results() use HDF5_utilities use config, only: & config_name_phase => phase_name ! anticipate logical name + use material, only: & + phase_plasticityInstance, & material_phase_plasticity_type => phase_plasticity use plastic_phenopowerlaw, only: & plastic_phenopowerlaw_results @@ -1208,7 +1210,7 @@ subroutine constitutive_results() do p=1,size(config_name_phase) call HDF5_closeGroup(results_addGroup('current/phase/'//trim(config_name_phase(p)))) if (material_phase_plasticity_type(p) == PLASTICITY_PHENOPOWERLAW_ID) then - call plastic_phenopowerlaw_results(p,'current/phase/'//trim(config_name_phase(p))) + call plastic_phenopowerlaw_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) endif enddo From 4edaab6da68181f2ad3b78f779b30a90e71948db Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 13 Dec 2018 11:11:45 +0100 Subject: [PATCH 115/372] definition of cleavage systems did not work bct definition was overly complicated --- src/lattice.f90 | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 34535c7f0..b54feb007 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -2639,6 +2639,11 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) f, & !< index of my family s !< index of my system in current family + if (trim(structure) == 'bct' .and. cOverA > 2.0_pReal) & + call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) + if (trim(structure) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & + call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) + a = 0_pInt activeFamilies: do f = 1_pInt,size(active,1) activeSystems: do s = 1_pInt,active(f) @@ -2647,13 +2652,12 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) select case(trim(structure)) - case ('fcc','bcc') + case ('fcc','bcc','iso','ort','bct') direction = system(1:3,c) normal = system(4:6,c) case ('hex') if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & - call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) direction = [ system(1,c)*1.5_pReal, & (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & @@ -2663,12 +2667,6 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) - case ('bct') - if (cOverA > 2.0_pReal) & - call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) - direction = [system(1:2,c),system(3,c)*cOverA] - normal = [system(4:5,c),system(6,c)/cOverA] - case default call IO_error(137_pInt,ext_msg='buildCoordinateSystem: '//trim(structure)) From 25bd6faf7cd2ddaec6529810bb8738e2f36d69fa Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 14 Dec 2018 06:39:49 +0100 Subject: [PATCH 116/372] left over "if" caused wrong coordinate systems for hex --- src/lattice.f90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index b54feb007..1da02e192 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -2657,12 +2657,9 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) normal = system(4:6,c) case ('hex') - if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & - direction = [ system(1,c)*1.5_pReal, & (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) - normal = [ system(5,c), & (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) From 7e41ae264d42cbcbdbfd096fdb55b96989e99b67 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 14 Dec 2018 11:35:41 +0100 Subject: [PATCH 117/372] Made changes with the calling signature --- src/CPFEM2.f90 | 40 ++-- src/HDF5_utilities.f90 | 401 +++++++++++++++++++++++------------------ src/results.f90 | 2 +- 3 files changed, 243 insertions(+), 200 deletions(-) mode change 100644 => 100755 src/CPFEM2.f90 mode change 100644 => 100755 src/HDF5_utilities.f90 mode change 100644 => 100755 src/results.f90 diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 old mode 100644 new mode 100755 index e22909231..b7de1d346 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -154,26 +154,26 @@ subroutine CPFEM_init fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - call HDF5_read(material_phase, fileHandle,'recordedPhase') - call HDF5_read(crystallite_F0, fileHandle,'convergedF') - call HDF5_read(crystallite_Fp0, fileHandle,'convergedFp') - call HDF5_read(crystallite_Fi0, fileHandle,'convergedFi') - call HDF5_read(crystallite_Lp0, fileHandle,'convergedLp') - call HDF5_read(crystallite_Li0, fileHandle,'convergedLi') - call HDF5_read(crystallite_dPdF0, fileHandle,'convergeddPdF') - call HDF5_read(crystallite_Tstar0_v,fileHandle,'convergedTstar') + call HDF5_read(fileHandle,material_phase,'recordedPhase') + call HDF5_read(fileHandle, crystallite_F0,'convergedF') + call HDF5_read(fileHandle, crystallite_Fp0,'convergedFp') + call HDF5_read(fileHandle, crystallite_Fi0,'convergedFi') + call HDF5_read(fileHandle, crystallite_Lp0,'convergedLp') + call HDF5_read(fileHandle, crystallite_Li0,'convergedLi') + call HDF5_read(fileHandle, crystallite_dPdF0, 'convergeddPdF') + call HDF5_read(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') do ph = 1_pInt,size(phase_plasticity) write(PlasticItem,*) ph,'_' - call HDF5_read(plasticState(ph)%state0,groupPlasticID,trim(PlasticItem)//'convergedStateConst') + call HDF5_read(groupPlasticID,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') enddo call HDF5_closeGroup(groupPlasticID) groupHomogID = HDF5_openGroup(fileHandle,'HomogStates') do homog = 1_pInt, material_Nhomogenization write(HomogItem,*) homog,'_' - call HDF5_read(homogState(homog)%state0, groupHomogID,trim(HomogItem)//'convergedStateHomog') + call HDF5_read(groupHomogID,homogState(homog)%state0, trim(HomogItem)//'convergedStateHomog') enddo call HDF5_closeGroup(groupHomogID) @@ -282,26 +282,26 @@ subroutine CPFEM_age() write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - call HDF5_write(material_phase, fileHandle,'recordedPhase') - call HDF5_write(crystallite_F0, fileHandle,'convergedF') - call HDF5_write(crystallite_Fp0, fileHandle,'convergedFp') - call HDF5_write(crystallite_Fi0, fileHandle,'convergedFi') - call HDF5_write(crystallite_Lp0, fileHandle,'convergedLp') - call HDF5_write(crystallite_Li0, fileHandle,'convergedLi') - call HDF5_write(crystallite_dPdF0, fileHandle,'convergeddPdF') - call HDF5_write(crystallite_Tstar0_v,fileHandle,'convergedTstar') + call HDF5_write(fileHandle, material_phase,'recordedPhase') + call HDF5_write(fileHandle, crystallite_F0,'convergedF') + call HDF5_write(fileHandle, crystallite_Fp0,'convergedFp') + call HDF5_write(fileHandle, crystallite_Fi0,'convergedFi') + call HDF5_write(fileHandle, crystallite_Lp0,'convergedLp') + call HDF5_write(fileHandle, crystallite_Li0,'convergedLi') + call HDF5_write(fileHandle, crystallite_dPdF0,'convergeddPdF') + call HDF5_write(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') do ph = 1_pInt,size(phase_plasticity) write(PlasticItem,*) ph,'_' - call HDF5_write(plasticState(ph)%state0,groupPlastic,trim(PlasticItem)//'convergedStateConst') + call HDF5_write(groupPlastic,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') enddo call HDF5_closeGroup(groupPlastic) groupHomog = HDF5_addGroup(fileHandle,'HomogStates') do homog = 1_pInt, material_Nhomogenization write(HomogItem,*) homog,'_' - call HDF5_write(homogState(homog)%state0,groupHomog,trim(HomogItem)//'convergedStateHomog') + call HDF5_write(groupHomog,homogState(homog)%state0,trim(HomogItem)//'convergedStateHomog') enddo call HDF5_closeGroup(groupHomog) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100644 new mode 100755 index 32747218c..d6c3748f7 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -331,7 +331,7 @@ end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal1(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -416,9 +416,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal1 @@ -426,7 +426,7 @@ end subroutine HDF5_read_pReal1 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal2(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -511,9 +511,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal2 @@ -521,7 +521,7 @@ end subroutine HDF5_read_pReal2 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal3(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -606,9 +606,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal3 @@ -616,7 +616,7 @@ end subroutine HDF5_read_pReal3 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal4(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -701,9 +701,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal4 @@ -711,7 +711,7 @@ end subroutine HDF5_read_pReal4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal5(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -796,9 +796,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal5 @@ -806,7 +806,7 @@ end subroutine HDF5_read_pReal5 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal6(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -891,9 +891,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal6 @@ -901,7 +901,7 @@ end subroutine HDF5_read_pReal6 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal7(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -986,9 +986,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simpl call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') end subroutine HDF5_read_pReal7 @@ -996,7 +996,7 @@ end subroutine HDF5_read_pReal7 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt1(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1083,9 +1083,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt1 @@ -1093,7 +1093,7 @@ end subroutine HDF5_read_pInt1 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt2(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1180,9 +1180,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt2 @@ -1190,7 +1190,7 @@ end subroutine HDF5_read_pInt2 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt3(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1277,9 +1277,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt3 @@ -1287,7 +1287,7 @@ end subroutine HDF5_read_pInt3 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt4(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1374,9 +1374,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt4 @@ -1384,7 +1384,7 @@ end subroutine HDF5_read_pInt4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt5(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1471,9 +1471,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt5 @@ -1481,7 +1481,7 @@ end subroutine HDF5_read_pInt5 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt6(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1568,9 +1568,9 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt6 @@ -1578,7 +1578,7 @@ end subroutine HDF5_read_pInt6 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt7(dataset,loc_id,datasetName,parallel) +subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1665,20 +1665,20 @@ if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/memspace_id') end subroutine HDF5_read_pInt7 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize - + implicit none real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle @@ -1700,11 +1700,14 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(1) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -1713,6 +1716,7 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') endif; endif #endif + myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:0),sum(outputSize)] @@ -1721,19 +1725,18 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -1743,26 +1746,26 @@ subroutine HDF5_write_pReal1(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_PReal1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') -end subroutine HDF5_write_PReal1 +end subroutine HDF5_write_pReal1 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1788,11 +1791,14 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(2) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -1801,6 +1807,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') endif; endif #endif + myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:1),sum(outputSize)] @@ -1809,19 +1816,18 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -1831,7 +1837,7 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -1840,9 +1846,9 @@ subroutine HDF5_write_pReal2(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal2 @@ -1850,7 +1856,7 @@ end subroutine HDF5_write_pReal2 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1876,11 +1882,14 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(3) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -1889,6 +1898,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') endif; endif #endif + myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:2),sum(outputSize)] @@ -1897,19 +1907,18 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -1919,7 +1928,7 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -1928,9 +1937,9 @@ subroutine HDF5_write_pReal3(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal3 @@ -1938,7 +1947,7 @@ end subroutine HDF5_write_pReal3 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -1964,11 +1973,14 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(4) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -1977,6 +1989,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') endif; endif #endif + myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:3),sum(outputSize)] @@ -1985,19 +1998,18 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2007,7 +2019,7 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -2016,9 +2028,9 @@ subroutine HDF5_write_pReal4(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal4 @@ -2026,7 +2038,7 @@ end subroutine HDF5_write_pReal4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2052,11 +2064,14 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(5) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -2065,6 +2080,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') endif; endif #endif + myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:4),sum(outputSize)] @@ -2073,19 +2089,18 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2095,7 +2110,7 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -2104,9 +2119,9 @@ subroutine HDF5_write_pReal5(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal5 @@ -2114,7 +2129,7 @@ end subroutine HDF5_write_pReal5 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2140,11 +2155,14 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(6) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -2153,6 +2171,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') endif; endif #endif + myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:5),sum(outputSize)] @@ -2161,19 +2180,18 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2183,7 +2201,7 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -2192,9 +2210,9 @@ subroutine HDF5_write_pReal6(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal6 @@ -2202,7 +2220,7 @@ end subroutine HDF5_write_pReal6 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2228,11 +2246,14 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) localShape = shape(dataset) if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- allocate(outputSize(worldsize), source = 0_pInt) outputSize(worldrank+1) = localShape(7) + #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -2241,6 +2262,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') endif; endif #endif + myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) globalShape = [localShape(1:6),sum(outputSize)] @@ -2249,19 +2271,18 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2271,7 +2292,7 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces @@ -2280,9 +2301,9 @@ subroutine HDF5_write_pReal7(dataset,loc_id,datasetName,parallel) call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') end subroutine HDF5_write_pReal7 @@ -2292,7 +2313,7 @@ end subroutine HDF5_write_pReal7 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2316,8 +2337,10 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2326,9 +2349,9 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt1: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') endif; endif #endif myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) @@ -2339,19 +2362,18 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2361,14 +2383,14 @@ subroutine HDF5_write_pInt1(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2380,7 +2402,7 @@ end subroutine HDF5_write_pInt1 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2404,8 +2426,10 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2414,9 +2438,9 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt2: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') endif; endif #endif myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2427,19 +2451,18 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2449,14 +2472,14 @@ subroutine HDF5_write_pInt2(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2468,7 +2491,7 @@ end subroutine HDF5_write_pInt2 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2492,8 +2515,10 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2502,9 +2527,9 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt3: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') endif; endif #endif myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2515,19 +2540,18 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2537,14 +2561,14 @@ subroutine HDF5_write_pInt3(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2556,7 +2580,7 @@ end subroutine HDF5_write_pInt3 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2580,8 +2604,10 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2590,9 +2616,9 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt4: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2603,19 +2629,18 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2625,14 +2650,14 @@ subroutine HDF5_write_pInt4(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2644,7 +2669,7 @@ end subroutine HDF5_write_pInt4 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2668,8 +2693,10 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2678,9 +2705,9 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt5: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2691,19 +2718,18 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2713,14 +2739,14 @@ subroutine HDF5_write_pInt5(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2732,7 +2758,7 @@ end subroutine HDF5_write_pInt5 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2756,8 +2782,10 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2766,9 +2794,9 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt6: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2779,19 +2807,18 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2801,14 +2828,14 @@ subroutine HDF5_write_pInt6(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2820,7 +2847,7 @@ end subroutine HDF5_write_pInt6 !-------------------------------------------------------------------------------------------------- !> @brief subroutine for writing dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) +subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) use numerics, only: & worldrank, & worldsize @@ -2844,8 +2871,10 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return +if (any(localShape(1:size(localShape)) == 0)) return +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) !-------------------------------------------------------------------------------------------------- @@ -2854,9 +2883,9 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pInt7: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') endif; endif #endif myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) @@ -2867,19 +2896,18 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dopen_f') !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5screate_simple_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dcreate_f') - !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) @@ -2889,14 +2917,14 @@ subroutine HDF5_write_pInt7(dataset,loc_id,datasetName,parallel) ! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dread_f') !-------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') call h5sclose_f(filespace_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) @@ -2906,3 +2934,18 @@ end subroutine HDF5_write_pInt7 end module HDF5_Utilities + +!!!!!!!!!!!! + + + + + + + + + + + + + diff --git a/src/results.f90 b/src/results.f90 old mode 100644 new mode 100755 index 5fe35f0ee..e8c5477f0 --- a/src/results.f90 +++ b/src/results.f90 @@ -954,7 +954,7 @@ subroutine results_writeVectorDataset(group,dataset,label,SIunit) integer(HID_T) :: groupHandle groupHandle = results_openGroup(group) - call HDF5_write(dataset,groupHandle,label) + call HDF5_write(groupHandle,dataset,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeVectorDataset From 669d0c6c8f88b671275ebb4aa9d315c9e6ea3a84 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 14 Dec 2018 11:37:44 +0100 Subject: [PATCH 118/372] made it nonexecutable --- src/CPFEM2.f90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 src/CPFEM2.f90 diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 old mode 100755 new mode 100644 From d2c7b33cf6707aeaaa26ae618e456a492f462ba5 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Fri, 14 Dec 2018 11:39:08 +0100 Subject: [PATCH 119/372] New files made nonexecutable --- src/HDF5_utilities.f90 | 0 src/results.f90 | 0 2 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 src/HDF5_utilities.f90 mode change 100755 => 100644 src/results.f90 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 old mode 100755 new mode 100644 diff --git a/src/results.f90 b/src/results.f90 old mode 100755 new mode 100644 From 3e38c4ef8cb1b8740f2cb7357cde0b838846e8e2 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Sat, 15 Dec 2018 17:21:03 +0100 Subject: [PATCH 120/372] The attribute interface works for single processor output and single valued attribute --- src/HDF5_utilities.f90 | 146 ++++++++++++++++++++++++++--------------- 1 file changed, 93 insertions(+), 53 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index d6c3748f7..c24df5bf8 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -60,13 +60,22 @@ module HDF5_utilities module procedure HDF5_write_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK end interface HDF5_write - +!-------------------------------------------------------------------------------------------------- +!> @brief attached attributes of type char,pInt or pReal to a file/dataset/group +!-------------------------------------------------------------------------------------------------- + interface HDF5_attributes + module procedure HDF5_addStringAttribute + module procedure HDF5_addIntegerAttribute + module procedure HDF5_addRealAttribute + end interface HDF5_attributes +!-------------------------------------------------------------------------------------------------- public :: & HDF5_utilities_init, & HDF5_openFile, & HDF5_closeFile, & HDF5_addStringAttribute, & HDF5_addIntegerAttribute, & + HDF5_addRealAttribute, & HDF5_closeGroup ,& HDF5_openGroup, & HDF5_addGroup, & @@ -275,7 +284,7 @@ end subroutine HDF5_addStringAttribute !-------------------------------------------------------------------------------------------------- -!> @brief adds a StringAttribute to the results file +!> @brief adds a IntegerAttribute to the results file !-------------------------------------------------------------------------------------------------- subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) @@ -288,7 +297,7 @@ subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) call h5screate_f(H5S_SCALAR_F,space_id,hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5screate_f') - call h5tcopy_f(H5T_NATIVE_Integer, type_id, hdferr) + call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tcopy_f') call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tset_size_f') @@ -305,6 +314,37 @@ subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) end subroutine HDF5_addIntegerAttribute +!-------------------------------------------------------------------------------------------------- +!> @brief adds a Real number Attribute to the results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addRealAttribute(entity,attrLabel,attrValue) + + implicit none + integer(HID_T), intent(in) :: entity + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in) :: attrValue + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5screate_f') + call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tcopy_f') + call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tset_size_f') + call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5acreate_f') + call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5sclose_f') + +end subroutine HDF5_addRealAttribute + !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- @@ -382,8 +422,8 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -477,8 +517,8 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -572,8 +612,8 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -667,8 +707,8 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -762,8 +802,8 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -857,8 +897,8 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -952,8 +992,8 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1048,8 +1088,8 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1145,8 +1185,8 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1242,8 +1282,8 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1339,8 +1379,8 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1436,8 +1476,8 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1533,8 +1573,8 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1630,8 +1670,8 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) @@ -1729,7 +1769,7 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') @@ -1820,7 +1860,7 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dget_space_f') @@ -1911,7 +1951,7 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dget_space_f') @@ -2002,7 +2042,7 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dget_space_f') @@ -2093,7 +2133,7 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dget_space_f') @@ -2184,7 +2224,7 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dget_space_f') @@ -2275,7 +2315,7 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dget_space_f') @@ -2337,7 +2377,7 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2366,7 +2406,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dget_space_f') @@ -2426,7 +2466,7 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2455,7 +2495,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dget_space_f') @@ -2515,7 +2555,7 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2544,7 +2584,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dget_space_f') @@ -2604,7 +2644,7 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2633,7 +2673,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dget_space_f') @@ -2693,7 +2733,7 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2722,7 +2762,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dget_space_f') @@ -2782,7 +2822,7 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2811,7 +2851,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dget_space_f') @@ -2871,7 +2911,7 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) !------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = shape(dataset) -if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)) == 0)) return !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -2900,7 +2940,7 @@ if (any(localShape(1:size(localShape)) == 0)) return !-------------------------------------------------------------------------------------------------- ! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & + call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & int(globalShape,HSIZE_T)) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dget_space_f') @@ -2935,7 +2975,7 @@ end subroutine HDF5_write_pInt7 end module HDF5_Utilities -!!!!!!!!!!!! + From 36c7157ee956869085356d3f1a962867f471d24f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 17 Dec 2018 08:33:46 +0100 Subject: [PATCH 121/372] vectorized --- src/plastic_kinematichardening.f90 | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 85daab322..53cd2b08e 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -504,9 +504,8 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) do j = 1_pInt, prm%totalNslip - Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) ! sum of all gdot*SchmidTensor gives Lp + Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) - ! Calculation of the tangent of Lp ! sensitivity of Lp if (dNeq0(gdot_pos(j))) then dgdot_dtau_pos = gdot_pos(j)*prm%n_slip/tau_pos(j) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & @@ -616,24 +615,22 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) sumGamma = sum(stt%accshear(:,of)) do j = 1_pInt, prm%totalNslip - dot%crss(j,of) = & ! evolution of slip resistance j - dot_product(prm%interaction_SlipSlip(j,:),abs(gdot_pos+gdot_neg)) * & - ( prm%theta1(j) + & - (prm%theta0(j) - prm%theta1(j) & + dot%crss(j,of) = & + dot_product(prm%interaction_SlipSlip(j,:),dot%accshear(:,of)) * & + ( prm%theta1(j) + (prm%theta0(j) - prm%theta1(j) & + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)) & *exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & ! V term depending on the harding law ) - dot%crss_back(j,of) = & ! evolution of back stress resistance j - stt%sense(j,of)*abs(gdot_pos(j)+gdot_neg(j)) * & - ( prm%theta1_b(j) + & - (prm%theta0_b(j) - prm%theta1_b(j) & - + prm%theta0_b(j)*prm%theta1_b(j)/(prm%tau1_b(j)+stt%chi0(j,of)) & - *(stt%accshear(j,of)-state(instance)%gamma0(j,of))) & - *exp(-(state(instance)%accshear(j,of)-state(instance)%gamma0(j,of)) & - *prm%theta0_b(j)/(prm%tau1_b(j)+state(instance)%chi0(j,of))) & - ) ! V term depending on the harding law for back stress + enddo + dot%crss_back(:,of) = & + stt%sense(:,of)*dot%accshear(:,of) * & + ( prm%theta1_b + & + (prm%theta0_b - prm%theta1_b & + + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& + ) & + *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & + ) ! V term depending on the harding law for back stress - enddo end associate end subroutine plastic_kinehardening_dotState From b2062f2a1218ea0635ba9e4fc29c9db0904f4c4e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 17 Dec 2018 16:11:01 +0100 Subject: [PATCH 122/372] label were stored including [] and comments --- src/config.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/config.f90 b/src/config.f90 index 7ae800f30..3fa90684b 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -1,4 +1,4 @@ -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief Reads in the material configuration from file !> @details Reads the material configuration file, where solverJobName.materialConfig takes @@ -220,7 +220,7 @@ subroutine parseFile(sectionNames,part,line, & partPosition = [partPosition, i] ! needed when actually storing content do i = 1_pInt, size(partPosition) -1_pInt - sectionNames(i) = trim(adjustl(fileContent(partPosition(i)))) + sectionNames(i) = trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) do j = partPosition(i) + 1_pInt, partPosition(i+1) -1_pInt call part(i)%add(trim(adjustl(fileContent(j)))) enddo From 3f3e23c2c89839f55122124095b41ce3fb070de6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 17 Dec 2018 16:15:16 +0100 Subject: [PATCH 123/372] polished addAttribute and use it to store meta data --- src/CPFEM2.f90 | 37 ++++---- src/DAMASK_spectral.f90 | 4 +- src/HDF5_utilities.f90 | 168 ++++++++++++++++++++++------------ src/plastic_phenopowerlaw.f90 | 3 +- src/results.f90 | 65 +++++++------ 5 files changed, 164 insertions(+), 113 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index b7de1d346..50d9cd312 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -154,13 +154,13 @@ subroutine CPFEM_init fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - call HDF5_read(fileHandle,material_phase,'recordedPhase') - call HDF5_read(fileHandle, crystallite_F0,'convergedF') - call HDF5_read(fileHandle, crystallite_Fp0,'convergedFp') - call HDF5_read(fileHandle, crystallite_Fi0,'convergedFi') - call HDF5_read(fileHandle, crystallite_Lp0,'convergedLp') - call HDF5_read(fileHandle, crystallite_Li0,'convergedLi') - call HDF5_read(fileHandle, crystallite_dPdF0, 'convergeddPdF') + call HDF5_read(fileHandle,material_phase, 'recordedPhase') + call HDF5_read(fileHandle,crystallite_F0, 'convergedF') + call HDF5_read(fileHandle,crystallite_Fp0, 'convergedFp') + call HDF5_read(fileHandle,crystallite_Fi0, 'convergedFi') + call HDF5_read(fileHandle,crystallite_Lp0, 'convergedLp') + call HDF5_read(fileHandle,crystallite_Li0, 'convergedLi') + call HDF5_read(fileHandle,crystallite_dPdF0, 'convergeddPdF') call HDF5_read(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') @@ -282,13 +282,13 @@ subroutine CPFEM_age() write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - call HDF5_write(fileHandle, material_phase,'recordedPhase') - call HDF5_write(fileHandle, crystallite_F0,'convergedF') - call HDF5_write(fileHandle, crystallite_Fp0,'convergedFp') - call HDF5_write(fileHandle, crystallite_Fi0,'convergedFi') - call HDF5_write(fileHandle, crystallite_Lp0,'convergedLp') - call HDF5_write(fileHandle, crystallite_Li0,'convergedLi') - call HDF5_write(fileHandle, crystallite_dPdF0,'convergeddPdF') + call HDF5_write(fileHandle,material_phase, 'recordedPhase') + call HDF5_write(fileHandle,crystallite_F0, 'convergedF') + call HDF5_write(fileHandle,crystallite_Fp0, 'convergedFp') + call HDF5_write(fileHandle,crystallite_Fi0, 'convergedFi') + call HDF5_write(fileHandle,crystallite_Lp0, 'convergedLp') + call HDF5_write(fileHandle,crystallite_Li0, 'convergedLi') + call HDF5_write(fileHandle,crystallite_dPdF0, 'convergeddPdF') call HDF5_write(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') @@ -317,7 +317,7 @@ end subroutine CPFEM_age !-------------------------------------------------------------------------------------------------- !> @brief triggers writing of the results !-------------------------------------------------------------------------------------------------- -subroutine CPFEM_results(inc) +subroutine CPFEM_results(inc,time) use prec, only: & pInt use results @@ -327,13 +327,12 @@ subroutine CPFEM_results(inc) implicit none integer(pInt), intent(in) :: inc - character(len=16) :: incChar + real(pReal), intent(in) :: time call results_openJobFile - write(incChar,*) inc - call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) - call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') + call results_addIncrement(inc,time) call constitutive_results() + call results_removeLink('current') ! put this into closeJobFile call results_closeJobFile end subroutine CPFEM_results diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 index 781598f3d..fca67c97d 100644 --- a/src/DAMASK_spectral.f90 +++ b/src/DAMASK_spectral.f90 @@ -161,7 +161,6 @@ program DAMASK_spectral call results_openJobFile() - call results_addIncrement() call results_closeJobFile() !-------------------------------------------------------------------------------------------------- ! initialize field solver information @@ -426,6 +425,7 @@ program DAMASK_spectral writeUndeformed: if (interface_restartInc < 1_pInt) then write(6,'(1/,a)') ' ... writing initial configuration to file ........................' + call CPFEM_results(0_pInt,0.0_pReal) do i = 1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output outputIndex = int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & ! QUESTION: why not starting i at 0 instead of murky 1? min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) @@ -602,7 +602,7 @@ program DAMASK_spectral if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') enddo fileOffset = fileOffset + sum(outputSize) ! forward to current file position - call CPFEM_results(totalIncsCounter) + call CPFEM_results(totalIncsCounter,time) endif if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c24df5bf8..c04694265 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -35,7 +35,7 @@ module HDF5_utilities module procedure HDF5_read_pInt4 module procedure HDF5_read_pInt5 module procedure HDF5_read_pInt6 - module procedure HDF5_read_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK + module procedure HDF5_read_pInt7 end interface HDF5_read @@ -57,25 +57,26 @@ module HDF5_utilities module procedure HDF5_write_pInt4 module procedure HDF5_write_pInt5 module procedure HDF5_write_pInt6 - module procedure HDF5_write_pInt7 !ABOVE 8 DIMENSIONS IT GIVES ERROR: THE CALL TO H5DREAD_F DOESNT WORK + module procedure HDF5_write_pInt7 end interface HDF5_write + !-------------------------------------------------------------------------------------------------- !> @brief attached attributes of type char,pInt or pReal to a file/dataset/group !-------------------------------------------------------------------------------------------------- - interface HDF5_attributes - module procedure HDF5_addStringAttribute - module procedure HDF5_addIntegerAttribute - module procedure HDF5_addRealAttribute - end interface HDF5_attributes + interface HDF5_addAttribute + module procedure HDF5_addAttribute_str + module procedure HDF5_addAttribute_pInt + module procedure HDF5_addAttribute_pReal + end interface HDF5_addAttribute + + !-------------------------------------------------------------------------------------------------- public :: & HDF5_utilities_init, & HDF5_openFile, & HDF5_closeFile, & - HDF5_addStringAttribute, & - HDF5_addIntegerAttribute, & - HDF5_addRealAttribute, & + HDF5_addAttribute, & HDF5_closeGroup ,& HDF5_openGroup, & HDF5_addGroup, & @@ -253,118 +254,165 @@ end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- -!> @brief adds a StringAttribute to the results file +!> @brief adds a string attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) +subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) implicit none - integer(HID_T), intent(in) :: entity + integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel, attrValue + character(len=*), intent(in), optional :: path integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5screate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tcopy_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tset_size_f') - call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5acreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5awrite_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5aclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5tclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addStringAttribute: h5sclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') -end subroutine HDF5_addStringAttribute +end subroutine HDF5_addAttribute_str !-------------------------------------------------------------------------------------------------- -!> @brief adds a IntegerAttribute to the results file +!> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addIntegerAttribute(entity,attrLabel,attrValue) +subroutine HDF5_addAttribute_pInt(loc_id,attrLabel,attrValue,path) implicit none - integer(HID_T), intent(in) :: entity + integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel integer(pInt), intent(in) :: attrValue + character(len=*), intent(in), optional :: path integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5screate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5screate_f') call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tcopy_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tcopy_f') call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tset_size_f') - call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5acreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5acreate_f') call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5awrite_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5aclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aclose_f') call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5tclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addIntegerAttribute: h5sclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5sclose_f') + +end subroutine HDF5_addAttribute_pInt -end subroutine HDF5_addIntegerAttribute !-------------------------------------------------------------------------------------------------- -!> @brief adds a Real number Attribute to the results file +!> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addRealAttribute(entity,attrLabel,attrValue) +subroutine HDF5_addAttribute_pReal(loc_id,attrLabel,attrValue,path) implicit none - integer(HID_T), intent(in) :: entity + integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue + real(pReal), intent(in) :: attrValue + character(len=*), intent(in), optional :: path integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5screate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5screate_f') call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tcopy_f') - call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tset_size_f') - call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5acreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tcopy_f') + call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) ! ToDo + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5acreate_f') call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5awrite_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5aclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aclose_f') call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5tclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addRealAttribute: h5sclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5sclose_f') + +end subroutine HDF5_addAttribute_pReal -end subroutine HDF5_addRealAttribute !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- -subroutine HDF5_setLink(fileHandle,path,link) +subroutine HDF5_setLink(loc_id,target_name,link_name) use hdf5 implicit none - character(len=*), intent(in) :: path, link - integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: target_name, link_name + integer(HID_T), intent(in) :: loc_id integer(HDF5_ERR_TYPE) :: hdferr logical :: linkExists - call h5lexists_f(fileHandle, link,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link)//')') + call h5lexists_f(loc_id, link_name,linkExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') if (linkExists) then - call h5ldelete_f(fileHandle,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link)//')') + call h5ldelete_f(loc_id,link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') endif - call h5lcreate_soft_f(path, fileHandle, link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(path)//' '//trim(link)//')') + call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') end subroutine HDF5_setLink diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 677d2872c..719292ac5 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -757,7 +757,7 @@ subroutine plastic_phenopowerlaw_results(instance,group) integer(pInt), intent(in) :: instance character(len=*) :: group integer(pInt) :: o - + associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) @@ -768,7 +768,6 @@ subroutine plastic_phenopowerlaw_results(instance,group) end select enddo outputsLoop end associate - !results_writeVectorDataset #else integer(pInt), intent(in) :: instance character(len=*) :: group diff --git a/src/results.f90 b/src/results.f90 index e8c5477f0..b1329a477 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -24,18 +24,11 @@ module results results_openJobFile, & results_closeJobFile, & results_addIncrement, & - HDF5_mappingPhase, & - HDF5_mappingHomog, & - HDF5_mappingCrystallite, & - HDF5_backwardMappingPhase, & - HDF5_backwardMappingHomog, & - HDF5_backwardMappingCrystallite, & - HDF5_mappingCells, & results_addGroup, & results_openGroup, & results_writeVectorDataset, & results_setLink, & - HDF5_removeLink + results_removeLink contains subroutine results_init @@ -62,7 +55,9 @@ subroutine results_openJobFile() implicit none resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) - + call HDF5_addAttribute(resultsFile,'DADF5version',0.1_pReal) + call HDF5_addAttribute(resultsFile,'DAMASKversion',DAMASKVERSION) + end subroutine results_openJobFile @@ -80,10 +75,16 @@ end subroutine results_closeJobFile !-------------------------------------------------------------------------------------------------- !> @brief closes the results file !-------------------------------------------------------------------------------------------------- -subroutine results_addIncrement() +subroutine results_addIncrement(inc,time) + implicit none + integer(pInt), intent(in) :: inc + real(pReal), intent(in) :: time + character(len=pStringLen) :: incChar - call HDF5_addIntegerAttribute(resultsFile,'test',1) + call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') + call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) end subroutine results_addIncrement @@ -112,6 +113,7 @@ integer(HID_T) function results_addGroup(groupName) end function results_addGroup + !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- @@ -126,10 +128,11 @@ subroutine results_setLink(path,link) end subroutine results_setLink + !-------------------------------------------------------------------------------------------------- !> @brief remove link to an object !-------------------------------------------------------------------------------------------------- -subroutine HDF5_removeLink(link) +subroutine results_removeLink(link) use hdf5 implicit none @@ -137,9 +140,27 @@ subroutine HDF5_removeLink(link) integer :: hdferr call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_removeLink: h5ldelete_soft_f ('//trim(link)//')') + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')') -end subroutine HDF5_removeLink +end subroutine results_removeLink + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeVectorDataset(group,dataset,label,SIunit) + + implicit none + character(len=*), intent(in) :: SIunit,label,group + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + call HDF5_write(groupHandle,dataset,label) + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeVectorDataset !-------------------------------------------------------------------------------------------------- @@ -943,21 +964,5 @@ subroutine HDF5_mappingCells(mapping) end subroutine HDF5_mappingCells -!-------------------------------------------------------------------------------------------------- -!> @brief creates a new vector dataset in the given group location -!-------------------------------------------------------------------------------------------------- -subroutine results_writeVectorDataset(group,dataset,label,SIunit) - - implicit none - character(len=*), intent(in) :: SIunit,label,group - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T) :: groupHandle - - groupHandle = results_openGroup(group) - call HDF5_write(groupHandle,dataset,label) - call HDF5_closeGroup(groupHandle) - -end subroutine results_writeVectorDataset - end module results From d00154299bd584859aff1fe948e175c95b38be7a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 17 Dec 2018 20:13:45 +0100 Subject: [PATCH 124/372] missing information on increment cause HDF5 error mistook write() statement with a left-over debug message --- src/results.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/results.f90 b/src/results.f90 index b1329a477..ccb3ec13c 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -82,6 +82,7 @@ subroutine results_addIncrement(inc,time) real(pReal), intent(in) :: time character(len=pStringLen) :: incChar + write(incChar,*) inc call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) From 27322847a48c21d9ade9fc83642b0bc3bf52d53e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 17 Dec 2018 21:30:10 +0100 Subject: [PATCH 125/372] reporting command line call --- src/results.f90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/results.f90 b/src/results.f90 index ccb3ec13c..718a5dbd9 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -52,11 +52,15 @@ end subroutine results_init subroutine results_openJobFile() use DAMASK_interface, only: & getSolverJobName + implicit none + character(len=pStringLen) :: commandLine resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) - call HDF5_addAttribute(resultsFile,'DADF5version',0.1_pReal) - call HDF5_addAttribute(resultsFile,'DAMASKversion',DAMASKVERSION) + call HDF5_addAttribute(resultsFile,'DADF5',0.1_pReal) + call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) + call get_command(commandLine) + call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) end subroutine results_openJobFile From 63c417fbe0d960f4af3590bf69f0de5b6100978c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 18 Dec 2018 06:34:18 +0100 Subject: [PATCH 126/372] failed if dataset does not exists empty datasets are not written out --- src/HDF5_utilities.f90 | 39 ++++++++++++++++++++++++++++++++++----- src/results.f90 | 3 ++- 2 files changed, 36 insertions(+), 6 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c04694265..2a05f101c 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -82,7 +82,8 @@ module HDF5_utilities HDF5_addGroup, & HDF5_read, & HDF5_write, & - HDF5_setLink + HDF5_setLink, & + HDF5_objectExists contains subroutine HDF5_utilities_init @@ -241,18 +242,46 @@ end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- !> @brief close a group !-------------------------------------------------------------------------------------------------- -subroutine HDF5_closeGroup(ID) +subroutine HDF5_closeGroup(group_id) implicit none - integer(HID_T), intent(in) :: ID + integer(HID_T), intent(in) :: group_id integer(HDF5_ERR_TYPE) :: hdferr - call h5gclose_f(ID, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(ID,pInt)) + call h5gclose_f(group_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) end subroutine HDF5_closeGroup +!-------------------------------------------------------------------------------------------------- +!> @brief check whether a group or a dataset exists +!-------------------------------------------------------------------------------------------------- +logical function HDF5_objectExists(loc_id,path) + + implicit none + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in), optional :: path + integer(HDF5_ERR_TYPE) :: hdferr + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif + + call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + + if(HDF5_objectExists) then + call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + endif + +end function HDF5_objectExists + + !-------------------------------------------------------------------------------------------------- !> @brief adds a string attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- diff --git a/src/results.f90 b/src/results.f90 index 718a5dbd9..d38178993 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -162,7 +162,8 @@ subroutine results_writeVectorDataset(group,dataset,label,SIunit) groupHandle = results_openGroup(group) call HDF5_write(groupHandle,dataset,label) - call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeVectorDataset From 0e4dede6062ca314443285c4718ea733c31f84bb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 18 Dec 2018 09:52:13 +0100 Subject: [PATCH 127/372] slowly approaching style of phenopowerlaw --- src/plastic_kinematichardening.f90 | 36 ++++++++++++++---------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 53cd2b08e..a06ccfeef 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -491,8 +491,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & - tau_pos,tau_neg - real(pReal) :: & + tau_pos,tau_neg, & dgdot_dtau_pos,dgdot_dtau_neg associate(prm => paramNew(instance), stt => state(instance)) @@ -501,25 +500,24 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & Mp,instance,of) + where (dNeq0(gdot_pos)) + dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos + else where + dgdot_dtau_pos = 0.0_pReal + end where + +where (dNeq0(gdot_neg)) + dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg +else where + dgdot_dtau_neg = 0.0_pReal +end where do j = 1_pInt, prm%totalNslip - - Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) - - if (dNeq0(gdot_pos(j))) then - dgdot_dtau_pos = gdot_pos(j)*prm%n_slip/tau_pos(j) - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dMp(k,l,m,n) = & - dLp_dMp(k,l,m,n) + dgdot_dtau_pos*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) - endif - - if (dNeq0(gdot_neg(j))) then - dgdot_dtau_neg = gdot_neg(j)*prm%n_slip/tau_neg(j) - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dMp(k,l,m,n) = & - dLp_dMp(k,l,m,n) + dgdot_dtau_neg*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) - endif - + Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + + dgdot_dtau_pos(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) & + + dgdot_dtau_neg(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) enddo end associate From f4cd4bbac555bf22602f9a94dbe88c7e2c8e00cc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 18 Dec 2018 18:17:06 +0100 Subject: [PATCH 128/372] cleaning --- src/homogenization_RGC.f90 | 74 ++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 43 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index f26c38453..8e331c185 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -13,14 +13,10 @@ module homogenization_RGC implicit none private - integer(pInt), dimension(:), allocatable, public :: & - homogenization_RGC_sizePostResults integer(pInt), dimension(:,:), allocatable,target, public :: & homogenization_RGC_sizePostResult character(len=64), dimension(:,:), allocatable,target, public :: & homogenization_RGC_output ! name of each post result output - integer(pInt), dimension(:), allocatable,target, public :: & - homogenization_RGC_Noutput !< number of outputs per homog instance enum, bind(c) enumerator :: undefined_ID, & @@ -125,7 +121,6 @@ subroutine homogenization_RGC_init() integer(kind(undefined_ID)) :: & outputID !< ID of each post result output character(len=65536), dimension(:), allocatable :: outputs - type(tParameters) :: prm write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_RGC_label//' init -+>>>' write(6,'(/,a)') ' Tjahjanto et al., International Journal of Material Forming, 2(1):939–942, 2009' @@ -139,13 +134,11 @@ subroutine homogenization_RGC_init() if (maxNinstance == 0_pInt) return if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance allocate(state(maxNinstance)) ! one container per instance allocate(dependentState(maxNinstance)) ! one container per instance - allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) homogenization_RGC_output='' allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& @@ -215,8 +208,7 @@ subroutine homogenization_RGC_init() ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component homogState(h)%sizeState = sizeHState - homogenization_RGC_sizePostResults(instance) = sum(homogenization_RGC_sizePostResult(:,instance)) - homogState(h)%sizePostResults = homogenization_RGC_sizePostResults(instance) + homogState(h)%sizePostResults = sum(homogenization_RGC_sizePostResult(:,instance)) allocate(homogState(h)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) @@ -269,7 +261,6 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 integer(pInt) :: iGrain,iFace,i,j - type(tParameters) :: prm !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations @@ -571,16 +562,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,param(instance)%Nconstituents) ! assembling of local dPdF into global Jacobian matrix + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem - iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate into global grain ID - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate into global grain ID + intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = interfaceNormal(intFaceN,instance,of) do iFace = 1_pInt,6_pInt - intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface + intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = interfaceNormal(intFaceN,instance,of) iMun = interface4to1(intFaceN,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent @@ -597,13 +588,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! identify the right/up/front grain (+|P) iGr3P = iGr3N iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem - iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate into global grain ID - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate into global grain ID + intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system normP = interfaceNormal(intFaceP,instance,of) do iFace = 1_pInt,6_pInt - intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface + intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = interfaceNormal(intFaceP,instance,of) - iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index + iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0_pInt) then ! get the corresponding tangent do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & @@ -637,9 +628,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = p_relax - call grainDeformation(pF,avgF,instance,of) ! compute the grains deformation from perturbed state - call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! compute stress penalty due to interface mismatch from perturbed state - call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state + call grainDeformation(pF,avgF,instance,of) ! rain deformation from perturbed state + call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! stress penalty due to interface mismatch from perturbed state + call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! stress penalty due to volume discrepancy from perturbed state !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state @@ -649,17 +640,17 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) - iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain + iGr3N = faceID(2:4) ! identify the grain ID in local coordinate system (3-dimensional index) + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identify the interface ID of the grain normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain + iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identify the grain ID in local coordinate system (3-dimensional index) + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identify the interface ID of the grain normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- @@ -796,8 +787,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (2) :: Gmoduli integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l,of real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb - - type(tParameters) :: prm real(pReal), parameter :: nDefToler = 1.0e-10_pReal logical :: debugActive @@ -825,24 +814,24 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! computing the mismatch and penalty stress tensor of all grains do iGrain = 1_pInt,product(prm%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) - muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain - bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector - iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position + muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain + bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector + iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position !* Looping over all six interfaces of each grain do iFace = 1_pInt,6_pInt - intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain + intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain nVect = interfaceNormal(intFace,instance,of) - iGNghb3 = iGrain3 ! identify the neighboring grain across the interface + iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) where(iGNghb3 < 1) iGNghb3 = nGDim where(iGNghb3 >nGDim) iGNghb3 = 1_pInt - iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain - Gmoduli = equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor + iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain + Gmoduli = equivalentModuli(iGNghb,ip,el) ! collect the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) bgGNghb = Gmoduli(2) - gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! compute the difference/jump in deformation gradeint across the neighbor + gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! difference/jump in deformation gradeint across the neighbor !-------------------------------------------------------------------------------------------------- ! compute the mismatch tensor of all interfaces @@ -850,12 +839,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) nDef = 0.0_pReal do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient + nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient enddo; enddo - nDefNorm = nDefNorm + nDef(i,j)**2.0_pReal ! compute the norm of the mismatch tensor + nDefNorm = nDefNorm + nDef(i,j)**2.0_pReal ! compute the norm of the mismatch tensor enddo; enddo - nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) - nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) + nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) + nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) if (debugActive) then write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb @@ -1082,8 +1071,7 @@ pure function homogenization_RGC_postResults(ip,el) result(postResults) el !< element number integer(pInt) instance,o,c,of - type(tParameters) :: prm - real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(material_homogenizationAt(el)))) :: & + real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,homogenization_typeInstance(material_homogenizationAt(el))))) :: & postResults instance = homogenization_typeInstance(material_homogenizationAt(el)) From 89196b953ff4437eda32f359fb2e86f6d4da2923 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 19 Dec 2018 06:57:28 +0100 Subject: [PATCH 129/372] simplified --- src/plastic_kinematichardening.f90 | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index a06ccfeef..ce2ede265 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -453,14 +453,8 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & tau_pos = tau_pos - stt%crss_back(:,of) tau_neg = tau_neg - stt%crss_back(:,of) - gdot_pos = 0.5_pReal * prm%gdot0 * & - (abs(tau_pos)/ & - state(instance)%crss(:,of))**prm%n_slip & - *sign(1.0_pReal,tau_pos) - gdot_neg = 0.5_pReal * prm%gdot0 * & - (abs(tau_neg)/ & - state(instance)%crss(:,of))**prm%n_slip & - *sign(1.0_pReal,tau_neg) + gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) + gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) end associate end subroutine plastic_kinehardening_shearRates From 2476dd4d8b3ae4625d33713cac51dbe577bc972d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 19 Dec 2018 07:30:43 +0100 Subject: [PATCH 130/372] shearRates more similar to kinetics --- src/plastic_kinematichardening.f90 | 38 ++++++++++++++++++------------ 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index ce2ede265..98ef866ac 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -425,8 +425,9 @@ end subroutine plastic_kinehardening_init !> @brief calculation of shear rates (\dot \gamma) !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) - + Mp,instance,of, dgdot_dtau_pos, & + dgdot_dtau_neg) + use prec use math implicit none @@ -440,6 +441,9 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & gdot_neg, & !< shear rates from negative line segments tau_pos, & !< shear stress on positive line segments tau_neg !< shear stress on negative line segments + real(pReal), dimension(paramNew(instance)%totalNslip), intent(out),optional :: & + dgdot_dtau_pos, & + dgdot_dtau_neg integer(pInt) :: & i @@ -455,7 +459,22 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) - + + if (present(dgdot_dtau_pos)) then + where(dNeq0(gdot_pos)) + dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos + else where + dgdot_dtau_pos = 0.0_pReal + end where + endif + if (present(dgdot_dtau_neg)) then + where(dNeq0(gdot_neg)) + dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg + else where + dgdot_dtau_neg = 0.0_pReal + end where + endif + end associate end subroutine plastic_kinehardening_shearRates @@ -493,18 +512,7 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) dLp_dMp = 0.0_pReal call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) - where (dNeq0(gdot_pos)) - dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos - else where - dgdot_dtau_pos = 0.0_pReal - end where - -where (dNeq0(gdot_neg)) - dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg -else where - dgdot_dtau_neg = 0.0_pReal -end where + Mp,instance,of,dgdot_dtau_pos,dgdot_dtau_neg) do j = 1_pInt, prm%totalNslip Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) From fe1183e010f781c910ca6565ea3bdeaed56859b7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 06:15:01 +0100 Subject: [PATCH 131/372] polishing --- src/plastic_disloUCLA.f90 | 58 +++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 9006b092d..b3d5321bc 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -39,30 +39,30 @@ module plastic_disloUCLA real(pReal) :: & aTolRho, & grainSize, & - SolidSolutionStrength, & !< Strength due to elements in solid solution + SolidSolutionStrength, & !< Strength due to elements in solid solution mu, & - D0, & !< prefactor for self-diffusion coefficient - Qsd !< activation energy for dislocation climb + D0, & !< prefactor for self-diffusion coefficient + Qsd !< activation energy for dislocation climb real(pReal), allocatable, dimension(:) :: & - rho0, & !< initial edge dislocation density per slip system for each family and instance - rhoDip0, & !< initial edge dipole density per slip system for each family and instance - burgers, & !< absolute length of burgers vector [m] for each slip system and instance + rho0, & !< initial edge dislocation density per slip system for each family and instance + rhoDip0, & !< initial edge dipole density per slip system for each family and instance + burgers, & !< absolute length of burgers vector [m] for each slip system and instance nonSchmidCoeff, & minDipDistance, & - CLambda, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + CLambda, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance atomicVolume, & !* mobility law parameters - H0kp, & !< activation energy for glide [J] for each slip system and instance - v0, & !< dislocation velocity prefactor [m/s] for each family and instance - p, & !< p-exponent in glide velocity - q, & !< q-exponent in glide velocity - B, & !< friction coeff. B (kMC) - kink_height, & !< height of the kink pair - kink_width, & !< width of the kink pair - omega, & !< attempt frequency for kink pair nucleation + H0kp, & !< activation energy for glide [J] for each slip system and instance + v0, & !< dislocation velocity prefactor [m/s] for each family and instance + p, & !< p-exponent in glide velocity + q, & !< q-exponent in glide velocity + B, & !< friction coefficient + kink_height, & !< height of the kink pair + kink_width, & !< width of the kink pair + omega, & !< attempt frequency for kink pair nucleation tau_Peierls real(pReal), allocatable, dimension(:,:) :: & - interaction_SlipSlip, & !< slip resistance from slip activity + interaction_SlipSlip, & !< slip resistance from slip activity forestProjectionEdge real(pReal), allocatable, dimension(:,:,:) :: & Schmid_slip, & @@ -152,13 +152,14 @@ subroutine plastic_disloUCLA_init() use lattice implicit none - integer(pInt) :: Ninstance,& - f,j,k,o, i, & - outputSize, & - offset_slip, index_myFamily, index_otherFamily, & - startIndex, endIndex, p, & - sizeState, sizeDotState, & - NipcMyPhase + integer(pInt) :: & + Ninstance, & + f,j,k,o, i, & + outputSize, & + offset_slip, index_myFamily, index_otherFamily, & + startIndex, endIndex, p, & + sizeState, sizeDotState, & + NipcMyPhase character(len=pStringLen) :: & structure = '',& extmsg = '' @@ -403,25 +404,24 @@ end subroutine plastic_disloUCLA_init subroutine plastic_disloUCLA_dependentState(instance,of) implicit none - integer(pInt), intent(in) :: instance, of + integer(pInt), intent(in) :: instance, of integer(pInt) :: & i real(pReal), dimension(param(instance)%totalNslip) :: & - invLambdaSlip ! 1/mean free distance between 2 forest dislocations seen by a moving dislocation + dislocationSpacing ! 1/mean free distance between 2 forest dislocations seen by a moving dislocation associate(prm => param(instance), stt => state(instance),dst => dependentState(instance)) forall (i = 1_pInt:prm%totalNslip) - invLambdaSlip(i) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & - prm%forestProjectionEdge(:,i))) & - / prm%Clambda(i) + dislocationSpacing(i) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & + prm%forestProjectionEdge(:,i))) dst%threshold_stress(i,of) = prm%mu*prm%burgers(i) & * sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & prm%interaction_SlipSlip(i,:))) end forall - dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*invLambdaSlip) + dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dislocationSpacing/prm%Clambda) end associate From ded65d250a3cb25e096b02d1de803e05c141e1e2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 07:27:03 +0100 Subject: [PATCH 132/372] re-enabled tests that were deactivated after orientation changes doxygen documentation only needed for development --- .gitlab-ci.yml | 39 ++++++++++++++++++--------------------- 1 file changed, 18 insertions(+), 21 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 99daef5e5..2464ae7d7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -158,12 +158,12 @@ Post_AverageDown: - master - release -#Post_General: -# stage: postprocessing -# script: PostProcessing/test.py -# except: -# - master -# - release +Post_General: + stage: postprocessing + script: PostProcessing/test.py + except: + - master + - release Post_GeometryReconstruction: stage: postprocessing @@ -364,12 +364,12 @@ Phenopowerlaw_singleSlip: - master - release -#TextureComponents: -# stage: spectral -# script: TextureComponents/test.py -# except: -# - master -# - release +TextureComponents: + stage: spectral + script: TextureComponents/test.py + except: + - master + - release ################################################################################################### @@ -468,27 +468,24 @@ AbaqusStd: script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT abaqus - except: - - master - - release + only: + - development Marc: stage: createDocumentation script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT marc - except: - - master - - release + only: + - development Spectral: stage: createDocumentation script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT spectral - except: - - master - - release + only: + - development ################################################################################################## backupData: From 2dc7b4cac64a76c5126af22d76523b71c12034fb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 08:40:28 +0100 Subject: [PATCH 133/372] building in parallel --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index a8a7a6e0f..cd2690cc7 100644 --- a/Makefile +++ b/Makefile @@ -7,11 +7,11 @@ all: spectral FEM processing .PHONY: spectral spectral: build/spectral - @(cd build/spectral;make --no-print-directory -ws all install;) + @(cd build/spectral;make -j4 --no-print-directory -ws all install;) .PHONY: FEM FEM: build/FEM - @(cd build/FEM; make --no-print-directory -ws all install;) + @(cd build/FEM; make -j4 --no-print-directory -ws all install;) .PHONY: build/spectral build/spectral: From 8832c04dd01842b6887cce5d6908c5b9a44b0f27 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 11:52:23 +0100 Subject: [PATCH 134/372] more sanity checks number of arguments for values per system needs to match the number of systems that are defined --- src/IO.f90 | 2 ++ src/config.f90 | 16 ++++++++++++---- src/plastic_phenopowerlaw.f90 | 8 ++++---- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/IO.f90 b/src/IO.f90 index af59b11b9..193580fcc 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -1251,6 +1251,8 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) msg = 'negative number systems requested' case (145_pInt) msg = 'too many systems requested' + case (146_pInt) + msg = 'number of values does not match' !-------------------------------------------------------------------------------------------------- ! material error messages and related messages in mesh diff --git a/src/config.f90 b/src/config.f90 index 441dd953c..c7fd95b43 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -550,7 +550,7 @@ end function getString !> @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,requiredShape) +function getFloats(this,key,defaultVal,requiredShape,requiredSize) use IO, only: & IO_error, & IO_stringValue, & @@ -561,7 +561,8 @@ function getFloats(this,key,defaultVal,requiredShape) class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key real(pReal), dimension(:), intent(in), optional :: defaultVal - integer(pInt), dimension(:), intent(in), optional :: requiredShape + integer(pInt), dimension(:), intent(in), optional :: requiredShape ! not useful (is always 1D array) + integer(pInt), intent(in), optional :: requiredSize type(tPartitionedStringList), pointer :: item integer(pInt) :: i logical :: found, & @@ -588,6 +589,9 @@ function getFloats(this,key,defaultVal,requiredShape) if (.not. found) then if (present(defaultVal)) then; getFloats = defaultVal; else; call IO_error(140_pInt,ext_msg=key); endif endif + if (present(requiredSize)) then + if(requiredSize /= size(getFloats)) call IO_error(146,ext_msg=key) + endif end function getFloats @@ -597,7 +601,7 @@ end function getFloats !> @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,requiredShape) +function getInts(this,key,defaultVal,requiredShape,requiredSize) use IO, only: & IO_error, & IO_stringValue, & @@ -608,7 +612,8 @@ function getInts(this,key,defaultVal,requiredShape) class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key integer(pInt), dimension(:), intent(in), optional :: defaultVal, & - requiredShape + requiredShape ! not useful (is always 1D array) + integer(pInt), intent(in), optional :: requiredSize type(tPartitionedStringList), pointer :: item integer(pInt) :: i logical :: found, & @@ -635,6 +640,9 @@ function getInts(this,key,defaultVal,requiredShape) if (.not. found) then if (present(defaultVal)) then; getInts = defaultVal; else; call IO_error(140_pInt,ext_msg=key); endif endif + if (present(requiredSize)) then + if(requiredSize /= size(getInts)) call IO_error(146,ext_msg=key) + endif end function getInts diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 053fe958b..531c1946d 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -217,9 +217,9 @@ subroutine plastic_phenopowerlaw_init config_phase(p)%getFloats('interaction_slipslip'), & structure(1:3)) - prm%xi_slip_0 = config_phase(p)%getFloats('tau0_slip', requiredShape=shape(prm%Nslip)) - prm%xi_slip_sat = config_phase(p)%getFloats('tausat_slip', requiredShape=shape(prm%Nslip)) - prm%H_int = config_phase(p)%getFloats('h_int', requiredShape=shape(prm%Nslip), & + prm%xi_slip_0 = config_phase(p)%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) + prm%xi_slip_sat = config_phase(p)%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) + prm%H_int = config_phase(p)%getFloats('h_int', requiredSize=size(prm%Nslip), & defaultVal=[(0.0_pReal,i=1_pInt,size(prm%Nslip))]) prm%gdot0_slip = config_phase(p)%getFloat('gdot0_slip') @@ -256,7 +256,7 @@ subroutine plastic_phenopowerlaw_init prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,structure(1:3),& config_phase(p)%getFloat('c/a')) - prm%xi_twin_0 = config_phase(p)%getFloats('tau0_twin',requiredShape=shape(prm%Ntwin)) + prm%xi_twin_0 = config_phase(p)%getFloats('tau0_twin',requiredSize=size(prm%Ntwin)) prm%gdot0_twin = config_phase(p)%getFloat('gdot0_twin') prm%n_twin = config_phase(p)%getFloat('n_twin') From fc171f388ab89f6e2115680413c99dbcfb6e1580 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 11:53:41 +0100 Subject: [PATCH 135/372] tests were updated --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index b9a52a85c..59b0cbe89 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit b9a52a85cd65cc27a8e863302bd984abdcad1455 +Subproject commit 59b0cbe899f272476fb6f00f0f8860428e6ceba3 From 2e8072b7681e9e8056ccb9cfa35f2b693c98d691 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 12:33:31 +0100 Subject: [PATCH 136/372] simplifying --- src/plastic_disloUCLA.f90 | 42 +++++++++------------------------------ 1 file changed, 9 insertions(+), 33 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index b3d5321bc..b07e9927a 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -29,10 +29,8 @@ module plastic_disloUCLA shearrate_ID, & accumulatedshear_ID, & mfp_ID, & - resolvedstress_ID, & thresholdstress_ID, & - dipoledistance_ID, & - stressexponent_ID + dipoledistance_ID end enum type, private :: tParameters @@ -309,14 +307,10 @@ subroutine plastic_disloUCLA_init() outputID = merge(accumulatedshear_ID,undefined_ID,prm%totalNslip>0_pInt) case ('mfp','mfp_slip') outputID = merge(mfp_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('resolved_stress','resolved_stress_slip') - outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) case ('threshold_stress','threshold_stress_slip') outputID = merge(thresholdstress_ID,undefined_ID,prm%totalNslip>0_pInt) case ('edge_dipole_distance') outputID = merge(dipoleDistance_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('stress_exponent') - outputID = merge(stressexponent_ID,undefined_ID,prm%totalNslip>0_pInt) end select if (outputID /= undefined_ID) then @@ -461,9 +455,6 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst enddo slipSystems end associate - Lp = 0.5_pReal * Lp - dLp_dMp = 0.5_pReal * dLp_dMp - end subroutine plastic_disloUCLA_LpAndItsTangent @@ -501,7 +492,7 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) dot%whole(:,of) = 0.0_pReal - dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg)*0.5_pReal + dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) @@ -574,29 +565,14 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdge(1_pInt:prm%totalNslip,of) case (rhoDip_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) - case (shearrate_ID,stressexponent_ID) + case (shearrate_ID) call kinetics(prm,stt,dst,Mp,Temperature,of, & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) - - if (prm%outputID(o) == shearrate_ID) then - postResults(c+1:c+prm%totalNslip) = (gdot_slip_pos + gdot_slip_neg)*0.5_pReal - elseif(prm%outputID(o) == stressexponent_ID) then - where (dNeq0(gdot_slip_pos+gdot_slip_neg)) - postResults(c+1_pInt:c + prm%totalNslip) = (tau_slip_pos+tau_slip_neg) * 0.5_pReal & - / (gdot_slip_pos+gdot_slip_neg) & - * (dgdot_dtauslip_pos+dgdot_dtauslip_neg) - else where - postResults(c+1_pInt:c + prm%totalNslip) = 0.0_pReal - end where - endif + gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) + postResults(c+1:c+prm%totalNslip) = gdot_slip_pos + gdot_slip_neg case (accumulatedshear_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip, of) case (mfp_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%mfp(1_pInt:prm%totalNslip, of) - case (resolvedstress_ID) - do i = 1_pInt, prm%totalNslip - postResults(c+i) =math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) - enddo case (thresholdstress_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%threshold_stress(1_pInt:prm%totalNslip,of) case (dipoleDistance_ID) @@ -678,7 +654,7 @@ math_mul33xx33 * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) - gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) + gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & * ( dst%mfp(:,of) - prm%kink_width ) & @@ -717,7 +693,7 @@ math_mul33xx33 )**2.0_pReal & ) - dgdot_dtauslip_pos = DotGamma0 * dvel_slip + dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal else where significantPositiveTau gdot_slip_pos = 0.0_pReal dgdot_dtauslip_pos = 0.0_pReal @@ -740,7 +716,7 @@ end where significantPositiveTau * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) - gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) + gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & * ( dst%mfp(:,of) - prm%kink_width ) & @@ -780,7 +756,7 @@ end where significantPositiveTau ) - dgdot_dtauslip_neg = DotGamma0 * dvel_slip + dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal else where significantNegativeTau gdot_slip_neg = 0.0_pReal dgdot_dtauslip_neg = 0.0_pReal From 24ddd8362d38b957859275c0ac6a80c8eae9b0d0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 12:46:43 +0100 Subject: [PATCH 137/372] cleaning and simplifying --- src/plastic_disloUCLA.f90 | 231 +++++++++++++++++++------------------- 1 file changed, 115 insertions(+), 116 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index b07e9927a..c3309ff89 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -90,6 +90,7 @@ module plastic_disloUCLA type, private :: tDisloUCLAdependentState real(pReal), allocatable, dimension(:,:) :: & mfp, & + dislocationSpacing, & threshold_stress end type tDisloUCLAdependentState @@ -382,6 +383,7 @@ subroutine plastic_disloUCLA_init() allocate(dst%mfp(prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(dst%dislocationSpacing(prm%totalNslip,NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress(prm%totalNslip,NipcMyPhase),source=0.0_pReal) @@ -402,20 +404,18 @@ subroutine plastic_disloUCLA_dependentState(instance,of) integer(pInt) :: & i - real(pReal), dimension(param(instance)%totalNslip) :: & - dislocationSpacing ! 1/mean free distance between 2 forest dislocations seen by a moving dislocation associate(prm => param(instance), stt => state(instance),dst => dependentState(instance)) forall (i = 1_pInt:prm%totalNslip) - dislocationSpacing(i) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & + dst%dislocationSpacing(i,of) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & prm%forestProjectionEdge(:,i))) dst%threshold_stress(i,of) = prm%mu*prm%burgers(i) & * sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & prm%interaction_SlipSlip(i,:))) end forall - dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dislocationSpacing/prm%Clambda) + dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dst%dislocationSpacing(:,of)/prm%Clambda) end associate @@ -471,7 +471,7 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) implicit none real(pReal), dimension(3,3), intent(in):: & - Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation + Mp !< Mandel stress real(pReal), intent(in) :: & temperature !< temperature at integration point integer(pInt), intent(in) :: & @@ -492,12 +492,11 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) dot%whole(:,of) = 0.0_pReal - dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) + dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) ! ToDo: needs to be abs VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) where(dEq0(tau_slip_pos)) - EdgeDipDistance = dst%mfp(:,of) !ToDo MD@FR: correct? was not handled properly before DotRhoDipFormation = 0.0_pReal DotRhoEdgeDipClimb = 0.0_pReal else where @@ -517,7 +516,7 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)) !* Spontaneous annihilation of 2 single edge dislocations dot%rhoEdgeDip(:,of) = DotRhoDipFormation & - - (2.0_pReal*prm%minDipDistance)/prm%burgers* stt%rhoEdgeDip(:,of)*abs(dot%accshear_slip(:,of)) & !* Spontaneous annihilation of a single edge dislocation with a dipole constituent + - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdgeDip(:,of)*abs(dot%accshear_slip(:,of)) & !* Spontaneous annihilation of a single edge dislocation with a dipole constituent - DotRhoEdgeDipClimb end associate @@ -603,8 +602,8 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & tol_math_check, & dEq, dNeq0 use math, only: & - pi, & -math_mul33xx33 + PI, & + math_mul33xx33 implicit none type(tParameters), intent(in) :: & @@ -637,132 +636,132 @@ math_mul33xx33 BoltzmannRatio = prm%H0kp/(kB*Temperature) DotGamma0 = stt%rhoEdge(:,of)*prm%burgers*prm%v0 - significantPositiveTau: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of)) & - / (prm%solidSolutionStrength+prm%tau_Peierls) - StressRatio_p = StressRatio** prm%p - StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + significantPositiveTau: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) + StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of)) & + / (prm%solidSolutionStrength+prm%tau_Peierls) + StressRatio_p = StressRatio** prm%p + StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) - vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & - * (tau_slip_pos & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - / ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) - - gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal - - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & - * ( & - (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - + tau_slip_pos & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & - ) & - * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) & - - (tau_slip_pos & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - * (2.0_pReal*(prm%burgers**2.0_pReal) & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& - ) & - ) & - / ( & - ( & + vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * ( dst%mfp(:,of) - prm%kink_width ) & + * (tau_slip_pos & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & + / ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + prm%omega * prm%B & *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - )**2.0_pReal & ) - dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal -else where significantPositiveTau - gdot_slip_pos = 0.0_pReal - dgdot_dtauslip_pos = 0.0_pReal -end where significantPositiveTau + gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal - significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of)) & - / (prm%solidSolutionStrength+prm%tau_Peierls) - StressRatio_p = StressRatio** prm%p - StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * ( dst%mfp(:,of) - prm%kink_width ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + + tau_slip_pos & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& + *BoltzmannRatio*prm%p& + *prm%q/& + (prm%solidSolutionStrength+prm%tau_Peierls)*& + StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & + ) & + * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + ) & + - (tau_slip_pos & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & + * (2.0_pReal*(prm%burgers**2.0_pReal) & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& + *BoltzmannRatio*prm%p& + *prm%q/& + (prm%solidSolutionStrength+prm%tau_Peierls)*& + StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& + ) & + ) & + / ( & + ( & + 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + )**2.0_pReal & + ) - vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & - * (tau_slip_neg & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - / ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) + dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal + else where significantPositiveTau + gdot_slip_pos = 0.0_pReal + dgdot_dtauslip_pos = 0.0_pReal + end where significantPositiveTau - gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal + significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) + StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of)) & + / (prm%solidSolutionStrength+prm%tau_Peierls) + StressRatio_p = StressRatio** prm%p + StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & - * ( & - (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - + tau_slip_neg & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & - ) & - * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) & - - (tau_slip_neg & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - * (2.0_pReal*(prm%burgers**2.0_pReal) & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& - ) & - ) & - / ( & - ( & + vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * ( dst%mfp(:,of) - prm%kink_width ) & + * (tau_slip_neg & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & + / ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + prm%omega * prm%B & *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - )**2.0_pReal & ) + gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal - dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal -else where significantNegativeTau - gdot_slip_neg = 0.0_pReal - dgdot_dtauslip_neg = 0.0_pReal -end where significantNegativeTau + dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * ( dst%mfp(:,of) - prm%kink_width ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + + tau_slip_neg & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& + *BoltzmannRatio*prm%p& + *prm%q/& + (prm%solidSolutionStrength+prm%tau_Peierls)*& + StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & + ) & + * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + ) & + - (tau_slip_neg & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & + * (2.0_pReal*(prm%burgers**2.0_pReal) & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& + *BoltzmannRatio*prm%p& + *prm%q/& + (prm%solidSolutionStrength+prm%tau_Peierls)*& + StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& + ) & + ) & + / ( & + ( & + 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + + prm%omega * prm%B & + *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + )**2.0_pReal & + ) + dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal + else where significantNegativeTau + gdot_slip_neg = 0.0_pReal + dgdot_dtauslip_neg = 0.0_pReal + end where significantNegativeTau + end subroutine kinetics + end module plastic_disloUCLA From da3f105875de285d1c60d5b51bc68a4705972a7c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 13:02:51 +0100 Subject: [PATCH 138/372] cleaner interface to kinetics --- src/plastic_disloUCLA.f90 | 67 +++++++++++++++++++++++---------------- 1 file changed, 39 insertions(+), 28 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index c3309ff89..4c0c8e4e9 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -437,15 +437,15 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst integer(pInt) :: i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg,tau_slip_pos,tau_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - call kinetics(prm,stt,dst,Mp,Temperature,of, & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) + call kinetics(Mp,Temperature,instance,of, & + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) slipSystems: do i = 1_pInt, 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) & @@ -488,8 +488,8 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance)) - call kinetics(prm,stt,dst,Mp,Temperature,of, & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) + call kinetics(Mp,Temperature,instance,of, & + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos,tau_slip_neg) dot%whole(:,of) = 0.0_pReal dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) ! ToDo: needs to be abs @@ -549,8 +549,8 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe integer(pInt) :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos, & - gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg + gdot_slip_pos,dgdot_dtauslip_pos, & + gdot_slip_neg,dgdot_dtauslip_neg associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) @@ -565,8 +565,8 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe case (rhoDip_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) case (shearrate_ID) - call kinetics(prm,stt,dst,Mp,Temperature,of, & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) + call kinetics(Mp,Temperature,instance,of, & + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) postResults(c+1:c+prm%totalNslip) = gdot_slip_pos + gdot_slip_neg case (accumulatedshear_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip, of) @@ -596,8 +596,8 @@ end function plastic_disloUCLA_postResults !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg) +pure subroutine kinetics(Mp,Temperature,instance,of, & + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos1,tau_slip_neg1) use prec, only: & tol_math_check, & dEq, dNeq0 @@ -606,32 +606,35 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tDisloUCLAState), intent(in) :: & - stt - type(tDisloUCLAdependentState), intent(in) :: & - dst real(pReal), dimension(3,3), intent(in) :: & Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: & temperature !< temperature at integration point integer(pInt), intent(in) :: & - of + of, instance integer(pInt) :: & j - real(pReal), intent(out), dimension(prm%totalNslip) :: & - gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg - real(pReal), dimension(prm%totalNslip) :: & + real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & + gdot_slip_pos,gdot_slip_neg + real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & + dgdot_dtauslip_pos,tau_slip_pos1,dgdot_dtauslip_neg,tau_slip_neg1 + real(pReal), dimension(param(instance)%totalNslip) :: & StressRatio, BoltzmannRatio, & StressRatio_p,StressRatio_pminus1, & - DotGamma0, dvel_slip, vel_slip + DotGamma0, dvel_slip, vel_slip, & + tau_slip_pos,tau_slip_neg + associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance)) + do j = 1_pInt, prm%totalNslip tau_slip_pos(j) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,j)) tau_slip_neg(j) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,j)) enddo + + + if (present(tau_slip_pos1)) tau_slip_pos1 = tau_slip_pos + if (present(tau_slip_neg1)) tau_slip_neg1 = tau_slip_neg BoltzmannRatio = prm%H0kp/(kB*Temperature) DotGamma0 = stt%rhoEdge(:,of)*prm%burgers*prm%v0 @@ -654,7 +657,11 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & ) gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal + else where significantPositiveTau + gdot_slip_pos = 0.0_pReal + end where significantPositiveTau + significantPositiveTau2: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & * ( dst%mfp(:,of) - prm%kink_width ) & * ( & @@ -693,10 +700,9 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & ) dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal - else where significantPositiveTau - gdot_slip_pos = 0.0_pReal + else where significantPositiveTau2 dgdot_dtauslip_pos = 0.0_pReal - end where significantPositiveTau + end where significantPositiveTau2 significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of)) & @@ -716,7 +722,11 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & ) gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal + else where significantNegativeTau + gdot_slip_neg = 0.0_pReal + end where significantNegativeTau + significantNegativeTau2: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & * ( dst%mfp(:,of) - prm%kink_width ) & * ( & @@ -756,10 +766,11 @@ pure subroutine kinetics(prm,stt,dst,Mp,Temperature,of, & dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal - else where significantNegativeTau - gdot_slip_neg = 0.0_pReal + else where significantNegativeTau2 dgdot_dtauslip_neg = 0.0_pReal - end where significantNegativeTau + end where significantNegativeTau2 + + end associate end subroutine kinetics From dcd22ccb6a4f04dcef23e59921f07c1ea05f8865 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 14:56:32 +0100 Subject: [PATCH 139/372] put private functions at the end for easy separation --- src/plastic_phenopowerlaw.f90 | 202 +++++++++++++++++----------------- 1 file changed, 103 insertions(+), 99 deletions(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 531c1946d..602f7701b 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -381,7 +381,7 @@ subroutine plastic_phenopowerlaw_init dot%gamma_twin => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear - plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally dot%whole => plasticState(p)%dotState end associate @@ -398,7 +398,7 @@ end subroutine plastic_phenopowerlaw_init subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) implicit none - real(pReal), dimension(3,3), intent(out) :: & + real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress @@ -420,9 +420,9 @@ subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance)) - call kinetics_slip(prm,stt,of,Mp,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) + 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 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) & @@ -431,7 +431,7 @@ subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) + dgdot_dtauslip_neg(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_neg(m,n,i) enddo slipSystems - call kinetics_twin(prm,stt,of,Mp,gdot_twin,dgdot_dtautwin) + call kinetics_twin(Mp,instance,of,gdot_twin,dgdot_dtautwin) twinSystems: do i = 1_pInt, 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) & @@ -452,7 +452,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(pInt), intent(in) :: & instance, & of @@ -487,9 +487,9 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) !-------------------------------------------------------------------------------------------------- ! shear rates - call kinetics_slip(prm,stt,of,Mp,gdot_slip_pos,gdot_slip_neg) + call kinetics_slip(Mp,instance,of,gdot_slip_pos,gdot_slip_neg) dot%gamma_slip(:,of) = abs(gdot_slip_pos+gdot_slip_neg) - call kinetics_twin(prm,stt,of,Mp,dot%gamma_twin(:,of)) + call kinetics_twin(Mp,instance,of,dot%gamma_twin(:,of)) !-------------------------------------------------------------------------------------------------- ! hardening @@ -509,41 +509,110 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) end subroutine plastic_phenopowerlaw_dotState +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) + use math, only: & + math_mul33xx33 + + implicit none + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + + real(pReal), dimension(sum(plastic_phenopowerlaw_sizePostResult(:,instance))) :: & + postResults + + integer(pInt) :: & + o,c,i + real(pReal), dimension(param(instance)%totalNslip) :: & + gdot_slip_pos,gdot_slip_neg + + postResults = 0.0_pReal + c = 0_pInt + + associate( prm => param(instance), stt => state(instance)) + + outputsLoop: do o = 1_pInt,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) + c = c + prm%totalNslip + case (accumulatedshear_slip_ID) + postResults(c+1_pInt: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 + c = c + prm%totalNslip + case (resolvedstress_slip_ID) + do i = 1_pInt, 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) + c = c + prm%totalNtwin + case (accumulatedshear_twin_ID) + postResults(c+1_pInt: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)) + c = c + prm%totalNtwin + case (resolvedstress_twin_ID) + do i = 1_pInt, prm%totalNtwin + postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) + enddo + c = c + prm%totalNtwin + + end select + enddo outputsLoop + + end associate + +end function plastic_phenopowerlaw_postResults + + !-------------------------------------------------------------------------------------------------- !> @brief calculates shear rates on slip systems and derivatives with respect to resolved stress !> @details Shear rates are calculated only optionally. ! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to ! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics_slip(prm,stt,of,Mp,gdot_slip_pos,gdot_slip_neg, & - dgdot_dtau_slip_pos,dgdot_dtau_slip_neg) +pure subroutine kinetics_slip(Mp,instance,of, & + gdot_slip_pos,gdot_slip_neg,dgdot_dtau_slip_pos,dgdot_dtau_slip_neg) use prec, only: & dNeq0 use math, only: & math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tPhenopowerlawState), intent(in) :: & - stt - integer(pInt), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & of - real(pReal), dimension(prm%totalNslip), intent(out) :: & + + real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & gdot_slip_pos, & gdot_slip_neg - real(pReal), dimension(prm%totalNslip), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNslip), intent(out), optional :: & dgdot_dtau_slip_pos, & dgdot_dtau_slip_neg - real(pReal), dimension(3,3), intent(in) :: & - Mp - real(pReal), dimension(prm%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & tau_slip_pos, & tau_slip_neg integer(pInt) :: i logical :: nonSchmidActive + associate(prm => param(instance), stt => state(instance)) + nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt do i = 1_pInt, prm%totalNslip @@ -580,6 +649,7 @@ pure subroutine kinetics_slip(prm,stt,of,Mp,gdot_slip_pos,gdot_slip_neg, & dgdot_dtau_slip_neg = 0.0_pReal end where endif + end associate end subroutine kinetics_slip @@ -591,29 +661,30 @@ end subroutine kinetics_slip ! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to ! have the optional arguments at the end. !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics_twin(prm,stt,of,Mp,gdot_twin,dgdot_dtau_twin) +pure subroutine kinetics_twin(Mp,instance,of,& + gdot_twin,dgdot_dtau_twin) use prec, only: & dNeq0 use math, only: & math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tPhenopowerlawState), intent(in) :: & - stt - integer(pInt), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & of - real(pReal), dimension(3,3), intent(in) :: & - Mp - real(pReal), dimension(prm%totalNtwin), intent(out) :: & + + real(pReal), dimension(param(instance)%totalNtwin), intent(out) :: & gdot_twin - real(pReal), dimension(prm%totalNtwin), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNtwin), intent(out), optional :: & dgdot_dtau_twin - real(pReal), dimension(prm%totalNtwin) :: & + real(pReal), dimension(param(instance)%totalNtwin) :: & tau_twin integer(pInt) :: i + + associate(prm => param(instance), stt => state(instance)) do i = 1_pInt, prm%totalNtwin tau_twin(i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) @@ -633,76 +704,9 @@ pure subroutine kinetics_twin(prm,stt,of,Mp,gdot_twin,dgdot_dtau_twin) dgdot_dtau_twin = 0.0_pReal end where endif - -end subroutine kinetics_twin - - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of constitutive results -!-------------------------------------------------------------------------------------------------- -function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) - use math, only: & - math_mul33xx33 - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer(pInt), intent(in) :: & - instance, & - of - - real(pReal), dimension(sum(plastic_phenopowerlaw_sizePostResult(:,instance))) :: & - postResults - - integer(pInt) :: & - o,c,i - real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg - - postResults = 0.0_pReal - c = 0_pInt - - associate( prm => param(instance), stt => state(instance)) - - outputsLoop: do o = 1_pInt,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) - c = c + prm%totalNslip - case (accumulatedshear_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%gamma_slip(1:prm%totalNslip,of) - c = c + prm%totalNslip - case (shearrate_slip_ID) - call kinetics_slip(prm,stt,of,Mp,gdot_slip_pos,gdot_slip_neg) - postResults(c+1_pInt:c+prm%totalNslip) = gdot_slip_pos+gdot_slip_neg - c = c + prm%totalNslip - case (resolvedstress_slip_ID) - do i = 1_pInt, 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) - c = c + prm%totalNtwin - case (accumulatedshear_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%gamma_twin(1:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (shearrate_twin_ID) - call kinetics_twin(prm,stt,of,Mp,postResults(c+1_pInt:c+prm%totalNtwin)) - c = c + prm%totalNtwin - case (resolvedstress_twin_ID) - do i = 1_pInt, prm%totalNtwin - postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) - enddo - c = c + prm%totalNtwin - - end select - enddo outputsLoop end associate -end function plastic_phenopowerlaw_postResults +end subroutine kinetics_twin end module plastic_phenopowerlaw From 939cd0e5bfd9b7f80a1b46224a29d10e06671bad Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 16:01:16 +0100 Subject: [PATCH 140/372] cleaning/adjusting names to paper --- src/plastic_disloUCLA.f90 | 133 ++++++++++++++++++++------------------ 1 file changed, 71 insertions(+), 62 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 4c0c8e4e9..de06d1863 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -42,21 +42,21 @@ module plastic_disloUCLA D0, & !< prefactor for self-diffusion coefficient Qsd !< activation energy for dislocation climb real(pReal), allocatable, dimension(:) :: & - rho0, & !< initial edge dislocation density per slip system for each family and instance - rhoDip0, & !< initial edge dipole density per slip system for each family and instance - burgers, & !< absolute length of burgers vector [m] for each slip system and instance + rho0, & !< initial edge dislocation density + rhoDip0, & !< initial edge dipole density + burgers, & !< absolute length of burgers vector [m] nonSchmidCoeff, & minDipDistance, & - CLambda, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + CLambda, & !< Adj. parameter for distance between 2 forest dislocations atomicVolume, & !* mobility law parameters - H0kp, & !< activation energy for glide [J] for each slip system and instance - v0, & !< dislocation velocity prefactor [m/s] for each family and instance + H0kp, & !< activation energy for glide [J] + v0, & !< dislocation velocity prefactor [m/s] p, & !< p-exponent in glide velocity q, & !< q-exponent in glide velocity B, & !< friction coefficient kink_height, & !< height of the kink pair - kink_width, & !< width of the kink pair + w, & !< width of the kink pair omega, & !< attempt frequency for kink pair nucleation tau_Peierls real(pReal), allocatable, dimension(:,:) :: & @@ -113,7 +113,6 @@ module plastic_disloUCLA contains - !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks @@ -233,7 +232,7 @@ subroutine plastic_disloUCLA_init() prm%q = config_phase(p)%getFloats('q_slip', requiredShape=shape(prm%Nslip), & defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) prm%kink_height = config_phase(p)%getFloats('kink_height', requiredShape=shape(prm%Nslip)) - prm%kink_width = config_phase(p)%getFloats('kink_width', requiredShape=shape(prm%Nslip)) + prm%w = config_phase(p)%getFloats('kink_width', requiredShape=shape(prm%Nslip)) prm%omega = config_phase(p)%getFloats('omega', requiredShape=shape(prm%Nslip)) prm%B = config_phase(p)%getFloats('friction_coeff', requiredShape=shape(prm%Nslip)) @@ -253,7 +252,7 @@ subroutine plastic_disloUCLA_init() prm%H0kp = math_expand(prm%H0kp, prm%Nslip) prm%burgers = math_expand(prm%burgers, prm%Nslip) prm%kink_height = math_expand(prm%kink_height, prm%Nslip) - prm%kink_width = math_expand(prm%kink_width, prm%Nslip) + prm%w = math_expand(prm%w, prm%Nslip) prm%omega = math_expand(prm%omega, prm%Nslip) prm%tau_Peierls = math_expand(prm%tau_Peierls, prm%Nslip) prm%v0 = math_expand(prm%v0, prm%Nslip) @@ -386,8 +385,7 @@ subroutine plastic_disloUCLA_init() allocate(dst%dislocationSpacing(prm%totalNslip,NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress(prm%totalNslip,NipcMyPhase),source=0.0_pReal) - - plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate enddo @@ -416,6 +414,8 @@ subroutine plastic_disloUCLA_dependentState(instance,of) end forall dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dst%dislocationSpacing(:,of)/prm%Clambda) + dst%dislocationSpacing(:,of) = dst%mfp(:,of) ! ToDo: Hack to recover wrong behavior for the moment + end associate @@ -428,24 +428,29 @@ end subroutine plastic_disloUCLA_dependentState pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance,of) implicit none - integer(pInt), intent(in) :: instance, of - real(pReal), intent(in) :: Temperature - real(pReal), dimension(3,3), intent(in) :: Mp - real(pReal), dimension(3,3), intent(out) :: Lp - real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp + real(pReal), dimension(3,3), intent(out) :: & + Lp + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLp_dMp + + real(pReal), dimension(3,3), intent(in):: & + Mp !< Mandel stress + real(pReal), intent(in) :: & + temperature !< temperature + integer(pInt), intent(in) :: & + instance, of integer(pInt) :: i,k,l,m,n - real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg - associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) + associate(prm => param(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal call kinetics(Mp,Temperature,instance,of, & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) + gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) slipSystems: do i = 1_pInt, 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) & @@ -453,6 +458,7 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst + 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 + end associate end subroutine plastic_disloUCLA_LpAndItsTangent @@ -473,7 +479,7 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) real(pReal), dimension(3,3), intent(in):: & Mp !< Mandel stress real(pReal), intent(in) :: & - temperature !< temperature at integration point + temperature !< temperature integer(pInt), intent(in) :: & instance, of @@ -483,43 +489,42 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) gdot_slip_pos, gdot_slip_neg,& tau_slip_pos,& tau_slip_neg, & - dgdot_dtauslip_neg,dgdot_dtauslip_pos,DotRhoDipFormation, ClimbVelocity, EdgeDipDistance, & + DotRhoDipFormation, ClimbVelocity, EdgeDipDistance, & DotRhoEdgeDipClimb associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance)) - call kinetics(Mp,Temperature,instance,of, & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos,tau_slip_neg) + call kinetics(Mp,Temperature,instance,of,& + gdot_slip_pos,gdot_slip_neg, & + tau_slip_pos1 = tau_slip_pos,tau_slip_neg1 = tau_slip_neg) dot%whole(:,of) = 0.0_pReal dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) ! ToDo: needs to be abs - VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) - where(dEq0(tau_slip_pos)) + where(dEq0(tau_slip_pos)) ! ToDo: use avg of pos and neg DotRhoDipFormation = 0.0_pReal DotRhoEdgeDipClimb = 0.0_pReal else where EdgeDipDistance = math_clip((3.0_pReal*prm%mu*prm%burgers)/(16.0_pReal*PI*abs(tau_slip_pos)), & - prm%minDipDistance, & ! lower limit - dst%mfp(:,of)) ! upper limit - DotRhoDipFormation = merge(((2.0_pReal*EdgeDipDistance)/prm%burgers)* stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)), & + prm%minDipDistance, & ! lower limit + dst%mfp(:,of)) ! upper limit + DotRhoDipFormation = merge(((2.0_pReal*EdgeDipDistance)/prm%burgers)* stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)), & ! ToDo: ignore region of spontaneous annihilation 0.0_pReal, & prm%dipoleformation) ClimbVelocity = (3.0_pReal*prm%mu*VacancyDiffusion*prm%atomicVolume/(2.0_pReal*pi*kB*Temperature)) & * (1.0_pReal/(EdgeDipDistance+prm%minDipDistance)) - DotRhoEdgeDipClimb = (4.0_pReal*ClimbVelocity*stt%rhoEdgeDip(:,of))/(EdgeDipDistance-prm%minDipDistance) + DotRhoEdgeDipClimb = (4.0_pReal*ClimbVelocity*stt%rhoEdgeDip(:,of))/(EdgeDipDistance-prm%minDipDistance) ! ToDo: Discuss with Franz: Stress dependency? end where - dot%rhoEdge(:,of) = abs(dot%accshear_slip(:,of))/(prm%burgers*dst%mfp(:,of)) & ! multiplication + dot%rhoEdge(:,of) = abs(dot%accshear_slip(:,of))/(prm%burgers*dst%mfp(:,of)) & ! multiplication - DotRhoDipFormation & - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)) !* Spontaneous annihilation of 2 single edge dislocations - dot%rhoEdgeDip(:,of) = DotRhoDipFormation & - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdgeDip(:,of)*abs(dot%accshear_slip(:,of)) & !* Spontaneous annihilation of a single edge dislocation with a dipole constituent - DotRhoEdgeDipClimb -end associate + end associate end subroutine plastic_disloUCLA_dotState @@ -538,7 +543,7 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & - Temperature !< Mandel stress + temperature !< temperature integer(pInt), intent(in) :: & instance, & of @@ -549,8 +554,8 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe integer(pInt) :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,dgdot_dtauslip_pos, & - gdot_slip_neg,dgdot_dtauslip_neg + gdot_slip_pos, & + gdot_slip_neg associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) @@ -565,8 +570,7 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe case (rhoDip_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) case (shearrate_ID) - call kinetics(Mp,Temperature,instance,of, & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) + call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg) postResults(c+1:c+prm%totalNslip) = gdot_slip_pos + gdot_slip_neg case (accumulatedshear_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip, of) @@ -574,7 +578,7 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNslip) = dst%mfp(1_pInt:prm%totalNslip, of) case (thresholdstress_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%threshold_stress(1_pInt:prm%totalNslip,of) - case (dipoleDistance_ID) + case (dipoleDistance_ID) ! ToDo: Discuss required changes with Franz do i = 1_pInt, prm%totalNslip if (dNeq0(abs(math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i))))) then postResults(c+i) = (3.0_pReal*prm%mu*prm%burgers(i)) & @@ -607,9 +611,9 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & implicit none real(pReal), dimension(3,3), intent(in) :: & - Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation + Mp !< Mandel stress real(pReal), intent(in) :: & - temperature !< temperature at integration point + temperature !< temperature integer(pInt), intent(in) :: & of, instance @@ -620,12 +624,13 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & dgdot_dtauslip_pos,tau_slip_pos1,dgdot_dtauslip_neg,tau_slip_neg1 real(pReal), dimension(param(instance)%totalNslip) :: & - StressRatio, BoltzmannRatio, & + StressRatio, & StressRatio_p,StressRatio_pminus1, & - DotGamma0, dvel_slip, vel_slip, & - tau_slip_pos,tau_slip_neg + dvel_slip, vel_slip, & + tau_slip_pos,tau_slip_neg, & + needsGoodName ! ToDo: @Karo: any idea? - associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do j = 1_pInt, prm%totalNslip tau_slip_pos(j) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,j)) @@ -636,23 +641,24 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & if (present(tau_slip_pos1)) tau_slip_pos1 = tau_slip_pos if (present(tau_slip_neg1)) tau_slip_neg1 = tau_slip_neg - BoltzmannRatio = prm%H0kp/(kB*Temperature) - DotGamma0 = stt%rhoEdge(:,of)*prm%burgers*prm%v0 + associate(BoltzmannRatio => prm%H0kp/(kB*Temperature), & + DotGamma0 => stt%rhoEdge(:,of)*prm%burgers*prm%v0) significantPositiveTau: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of)) & / (prm%solidSolutionStrength+prm%tau_Peierls) StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & + * ( dst%mfp(:,of) - prm%w ) & * (tau_slip_pos & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & / ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) @@ -661,9 +667,10 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & gdot_slip_pos = 0.0_pReal end where significantPositiveTau + if (present(dgdot_dtauslip_pos)) then significantPositiveTau2: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & + * ( dst%mfp(:,of) - prm%w ) & * ( & (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + tau_slip_pos & @@ -675,14 +682,14 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & ) & * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) & - (tau_slip_pos & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & * (2.0_pReal*(prm%burgers**2.0_pReal) & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& *BoltzmannRatio*prm%p& *prm%q/& @@ -694,7 +701,7 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & )**2.0_pReal & ) @@ -703,21 +710,23 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & else where significantPositiveTau2 dgdot_dtauslip_pos = 0.0_pReal end where significantPositiveTau2 + endif significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of)) & / (prm%solidSolutionStrength+prm%tau_Peierls) StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & + * ( dst%mfp(:,of) - prm%w ) & * (tau_slip_neg & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & / ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) @@ -726,9 +735,10 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & gdot_slip_neg = 0.0_pReal end where significantNegativeTau + if (present(dgdot_dtauslip_neg)) then significantNegativeTau2: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%kink_width ) & + * ( dst%mfp(:,of) - prm%w ) & * ( & (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & + tau_slip_neg & @@ -740,14 +750,14 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & ) & * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & ) & - (tau_slip_neg & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & * (2.0_pReal*(prm%burgers**2.0_pReal) & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& *BoltzmannRatio*prm%p& *prm%q/& @@ -759,20 +769,19 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & ( & 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%kink_width )**2.0_pReal) & + *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & )**2.0_pReal & ) - dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal else where significantNegativeTau2 dgdot_dtauslip_neg = 0.0_pReal end where significantNegativeTau2 - + end if + end associate end associate end subroutine kinetics - end module plastic_disloUCLA From 2d47af7f56a73c9b9e9e0f0be2af7bc7d1c3dd5b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 17:04:26 +0100 Subject: [PATCH 141/372] shortened --- src/plastic_disloUCLA.f90 | 154 +++++++++++++------------------------- 1 file changed, 54 insertions(+), 100 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index de06d1863..19d5de6f9 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -58,7 +58,8 @@ module plastic_disloUCLA kink_height, & !< height of the kink pair w, & !< width of the kink pair omega, & !< attempt frequency for kink pair nucleation - tau_Peierls + tau_Peierls, & + tau0 real(pReal), allocatable, dimension(:,:) :: & interaction_SlipSlip, & !< slip resistance from slip activity forestProjectionEdge @@ -110,7 +111,6 @@ module plastic_disloUCLA private :: & kinetics - contains !-------------------------------------------------------------------------------------------------- @@ -226,7 +226,7 @@ subroutine plastic_disloUCLA_init() prm%H0kp = config_phase(p)%getFloats('qedge', requiredShape=shape(prm%Nslip)) prm%clambda = config_phase(p)%getFloats('clambdaslip', requiredShape=shape(prm%Nslip)) - prm%tau_Peierls = config_phase(p)%getFloats('tau_peierls', requiredShape=shape(prm%Nslip)) + prm%tau_Peierls = config_phase(p)%getFloats('tau_peierls', requiredShape=shape(prm%Nslip)) ! ToDo: Deprecated prm%p = config_phase(p)%getFloats('p_slip', requiredShape=shape(prm%Nslip), & defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) prm%q = config_phase(p)%getFloats('q_slip', requiredShape=shape(prm%Nslip), & @@ -236,7 +236,7 @@ subroutine plastic_disloUCLA_init() prm%omega = config_phase(p)%getFloats('omega', requiredShape=shape(prm%Nslip)) prm%B = config_phase(p)%getFloats('friction_coeff', requiredShape=shape(prm%Nslip)) - prm%SolidSolutionStrength = config_phase(p)%getFloat('solidsolutionstrength') + prm%SolidSolutionStrength = config_phase(p)%getFloat('solidsolutionstrength') ! ToDo: Deprecated prm%grainSize = config_phase(p)%getFloat('grainsize') prm%D0 = config_phase(p)%getFloat('d0') prm%Qsd = config_phase(p)%getFloat('qsd') @@ -260,6 +260,9 @@ subroutine plastic_disloUCLA_init() prm%clambda = math_expand(prm%clambda, prm%Nslip) prm%atomicVolume = math_expand(prm%atomicVolume, prm%Nslip) prm%minDipDistance = math_expand(prm%minDipDistance, prm%Nslip) + + prm%tau0 = prm%tau_peierls + prm%SolidSolutionStrength + ! sanity checks if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0' @@ -642,25 +645,20 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & if (present(tau_slip_neg1)) tau_slip_neg1 = tau_slip_neg associate(BoltzmannRatio => prm%H0kp/(kB*Temperature), & - DotGamma0 => stt%rhoEdge(:,of)*prm%burgers*prm%v0) + DotGamma0 => stt%rhoEdge(:,of)*prm%burgers*prm%v0, & + effectiveLength => dst%mfp(:,of) - prm%w) significantPositiveTau: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of)) & - / (prm%solidSolutionStrength+prm%tau_Peierls) + StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of))/prm%tau0 StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%w ) & - * (tau_slip_pos & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - / ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) + * effectiveLength * tau_slip_pos * needsGoodName & + / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + + prm%omega * prm%B * effectiveLength**2.0_pReal* needsGoodName & + ) gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal else where significantPositiveTau @@ -669,42 +667,23 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & if (present(dgdot_dtauslip_pos)) then significantPositiveTau2: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%w ) & - * ( & - (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - + tau_slip_pos & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & - ) & - * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) & - - (tau_slip_pos & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - * (2.0_pReal*(prm%burgers**2.0_pReal) & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& - ) & - ) & - / ( & - ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - )**2.0_pReal & - ) + dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & + * ( & + (needsGoodName + tau_slip_pos * abs(needsGoodName)*BoltzmannRatio*prm%p & + * prm%q/prm%tau0 & + * StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) & + ) & + * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + + prm%omega * prm%B* effectiveLength **2.0_pReal* needsGoodName & + ) & + - tau_slip_pos * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + + prm%omega * prm%B *effectiveLength **2.0_pReal& + * (abs(needsGoodName)*BoltzmannRatio*prm%p *prm%q/prm%tau0 & + *StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& + ) & + ) & + /(2.0_pReal*prm%burgers**2.0_pReal*tau_slip_pos & + + prm%omega * prm%B* effectiveLength**2.0_pReal* needsGoodName )**2.0_pReal dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal else where significantPositiveTau2 @@ -713,22 +692,16 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & endif significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of)) & - / (prm%solidSolutionStrength+prm%tau_Peierls) + StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of))/prm%tau0 StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%w ) & - * (tau_slip_neg & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - / ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) + * effectiveLength * tau_slip_neg * needsGoodName & + / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + + prm%omega * prm%B * effectiveLength**2.0_pReal* needsGoodName & + ) gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal else where significantNegativeTau @@ -737,43 +710,24 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & if (present(dgdot_dtauslip_neg)) then significantNegativeTau2: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * ( dst%mfp(:,of) - prm%w ) & - * ( & - (exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - + tau_slip_neg & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) ) & - ) & - * (2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - ) & - - (tau_slip_neg & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) ) & - * (2.0_pReal*(prm%burgers**2.0_pReal) & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q))& - *BoltzmannRatio*prm%p& - *prm%q/& - (prm%solidSolutionStrength+prm%tau_Peierls)*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& - ) & - ) & - / ( & - ( & - 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & - + prm%omega * prm%B & - *(( dst%mfp(:,of) - prm%w )**2.0_pReal) & - * exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) & - )**2.0_pReal & - ) - + dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & + * ( & + (needsGoodName + tau_slip_neg * abs(needsGoodName)*BoltzmannRatio*prm%p & + * prm%q/prm%tau0 & + * StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) & + ) & + * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + + prm%omega * prm%B* effectiveLength **2.0_pReal* needsGoodName & + ) & + - tau_slip_neg * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + + prm%omega * prm%B *effectiveLength **2.0_pReal& + * (abs(needsGoodName)*BoltzmannRatio*prm%p *prm%q/prm%tau0 & + *StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& + ) & + ) & + /(2.0_pReal*prm%burgers**2.0_pReal*tau_slip_neg & + + prm%omega * prm%B* effectiveLength**2.0_pReal* needsGoodName )**2.0_pReal + dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal else where significantNegativeTau2 dgdot_dtauslip_neg = 0.0_pReal From d8a7fdd01d9431b22cb4d92d368b9bf9c9003533 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 18:14:54 +0100 Subject: [PATCH 142/372] function description was wrong --- src/plastic_phenopowerlaw.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 602f7701b..347e2d8f8 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -579,8 +579,8 @@ end function plastic_phenopowerlaw_postResults !-------------------------------------------------------------------------------------------------- -!> @brief calculates shear rates on slip systems and derivatives with respect to resolved stress -!> @details Shear rates are calculated only optionally. +!> @brief Shear rates on slip systems and their derivatives with respect to resolved stress +!> @details Derivatives are calculated only optionally. ! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to ! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- @@ -655,7 +655,7 @@ end subroutine kinetics_slip !-------------------------------------------------------------------------------------------------- -!> @brief calculates shear rates on twin systems and derivatives with respect to resolved stress. +!> @brief Shear rates on twin systems and their derivatives with respect to resolved stress. ! twinning is assumed to take place only in untwinned volume. !> @details Derivates are calculated only optionally. ! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to From b6cb456b2770ea762c352a4e327026688585c8af Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 18:15:56 +0100 Subject: [PATCH 143/372] function description as for phenopowerlaw --- src/plastic_disloUCLA.f90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 19d5de6f9..9fb4c9bf7 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -599,9 +599,12 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe end function plastic_disloUCLA_postResults - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +!> @brief Shear rates on slip systems, their derivatives with respect to resolved stress and the +! resolved stresss +!> @details Derivatives and resolved stress are calculated only optionally. +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- pure subroutine kinetics(Mp,Temperature,instance,of, & gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos1,tau_slip_neg1) From 9094bb9a646e0560edd33314adf85baf75a85a45 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 22:41:39 +0100 Subject: [PATCH 144/372] private functions at the end --- src/plastic_kinematichardening.f90 | 123 +++++++++++++++-------------- 1 file changed, 63 insertions(+), 60 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 98ef866ac..03713d300 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -21,8 +21,6 @@ module plastic_kinehardening integer(pInt), dimension(:), allocatable, target, public :: & plastic_kinehardening_Noutput !< number of outputs per instance - integer(pInt), dimension(:), allocatable, public, protected :: & - plastic_kinehardening_totalNslip !< no. of slip system used in simulation integer(pInt), dimension(:,:), allocatable, private :: & @@ -193,13 +191,14 @@ subroutine plastic_kinehardening_init plastic_kinehardening_output = '' allocate(plastic_kinehardening_Noutput(maxNinstance), source=0_pInt) allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) - allocate(plastic_kinehardening_totalNslip(maxNinstance), source=0_pInt) + allocate(param(maxNinstance)) ! one container of parameters per instance allocate(paramNew(maxNinstance)) allocate(state(maxNinstance)) allocate(state0(maxNinstance)) allocate(dotState(maxNinstance)) allocate(deltaState(maxNinstance)) + do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle instance = phase_plasticityInstance(p) ! which instance of my phase @@ -421,63 +420,6 @@ param(instance)%outputID = prm%outputID end subroutine plastic_kinehardening_init -!-------------------------------------------------------------------------------------------------- -!> @brief calculation of shear rates (\dot \gamma) -!-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of, dgdot_dtau_pos, & - dgdot_dtau_neg) - use prec - use math - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp - integer(pInt), intent(in) :: & - instance, & !< instance of that phase - of !< index of phaseMember - real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & - gdot_pos, & !< shear rates from positive line segments - gdot_neg, & !< shear rates from negative line segments - tau_pos, & !< shear stress on positive line segments - tau_neg !< shear stress on negative line segments - real(pReal), dimension(paramNew(instance)%totalNslip), intent(out),optional :: & - dgdot_dtau_pos, & - dgdot_dtau_neg - - integer(pInt) :: & - i - - associate(prm => paramNew(instance), stt => state(instance)) - do i = 1_pInt, prm%totalNslip - tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) - tau_neg(i) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) - enddo - - tau_pos = tau_pos - stt%crss_back(:,of) - tau_neg = tau_neg - stt%crss_back(:,of) - - gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) - gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) - - if (present(dgdot_dtau_pos)) then - where(dNeq0(gdot_pos)) - dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos - else where - dgdot_dtau_pos = 0.0_pReal - end where - endif - if (present(dgdot_dtau_neg)) then - where(dNeq0(gdot_neg)) - dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg - else where - dgdot_dtau_neg = 0.0_pReal - end where - endif - -end associate -end subroutine plastic_kinehardening_shearRates - !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent @@ -525,6 +467,7 @@ end associate end subroutine plastic_kinehardening_LpAndItsTangent + !-------------------------------------------------------------------------------------------------- !> @brief calculates (instantaneous) incremental change of microstructure !-------------------------------------------------------------------------------------------------- @@ -635,6 +578,7 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) end subroutine plastic_kinehardening_dotState + !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- @@ -782,4 +726,63 @@ pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dt end subroutine kinetics + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of shear rates (\dot \gamma) +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Mp,instance,of, dgdot_dtau_pos, & + dgdot_dtau_neg) + use prec + use math + + implicit none + real(pReal), dimension(3,3), intent(in) :: & + Mp + integer(pInt), intent(in) :: & + instance, & !< instance of that phase + of !< index of phaseMember + real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & + gdot_pos, & !< shear rates from positive line segments + gdot_neg, & !< shear rates from negative line segments + tau_pos, & !< shear stress on positive line segments + tau_neg !< shear stress on negative line segments + real(pReal), dimension(paramNew(instance)%totalNslip), intent(out),optional :: & + dgdot_dtau_pos, & + dgdot_dtau_neg + + integer(pInt) :: & + i + + associate(prm => paramNew(instance), stt => state(instance)) + do i = 1_pInt, prm%totalNslip + tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) + tau_neg(i) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) + enddo + + tau_pos = tau_pos - stt%crss_back(:,of) + tau_neg = tau_neg - stt%crss_back(:,of) + + gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) + gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) + + if (present(dgdot_dtau_pos)) then + where(dNeq0(gdot_pos)) + dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos + else where + dgdot_dtau_pos = 0.0_pReal + end where + endif + if (present(dgdot_dtau_neg)) then + where(dNeq0(gdot_neg)) + dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg + else where + dgdot_dtau_neg = 0.0_pReal + end where + endif + +end associate + +end subroutine plastic_kinehardening_shearRates + end module plastic_kinehardening From b3d14b00b655cc201545f5978cf4417690bb782d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 23:07:31 +0100 Subject: [PATCH 145/372] cleaning --- src/plastic_kinematichardening.f90 | 142 ++++++++++++----------------- 1 file changed, 60 insertions(+), 82 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 03713d300..edd0d3a8e 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -47,8 +47,6 @@ module plastic_kinehardening n_slip, & !< stress exponent for slip (input parameter) aTolResistance, & aTolShear - - real(pReal), dimension(:), allocatable, private :: & crss0, & !< initial critical shear stress for slip (input parameter, per family) theta0, & !< initial hardening rate of forward stress for each slip @@ -58,16 +56,13 @@ module plastic_kinehardening tau1, & tau1_b, & nonSchmidCoeff - real(pReal), dimension(:,:), allocatable, private :: & + real(pReal), dimension(:,:), allocatable, private :: & interaction_slipslip !< latent hardening matrix real(pReal), allocatable, dimension(:,:,:) :: & Schmid_slip, & Schmid_twin, & nonSchmid_pos, & nonSchmid_neg - - real(pReal), dimension(:,:), allocatable, private :: & - hardeningMatrix_SlipSlip integer(pInt) :: & totalNslip !< total number of active slip system integer(pInt), allocatable, dimension(:) :: & @@ -151,7 +146,7 @@ subroutine plastic_kinehardening_init o, i, p, & phase, & instance, & - maxNinstance, & + Ninstance, & NipcMyPhase, & outputSize, & offset_slip, & @@ -179,25 +174,25 @@ subroutine plastic_kinehardening_init write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - maxNinstance = int(count(phase_plasticity == PLASTICITY_KINEHARDENING_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(phase_plasticity == PLASTICITY_KINEHARDENING_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a,1x,i5,/)') '# instances:',Ninstance - allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),maxNinstance), & + allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),Ninstance), & source=0_pInt) - allocate(plastic_kinehardening_output(maxval(phase_Noutput),maxNinstance)) + allocate(plastic_kinehardening_output(maxval(phase_Noutput),Ninstance)) plastic_kinehardening_output = '' - allocate(plastic_kinehardening_Noutput(maxNinstance), source=0_pInt) - allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_kinehardening_Noutput(Ninstance), source=0_pInt) + allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,Ninstance), source=0_pInt) - allocate(param(maxNinstance)) ! one container of parameters per instance - allocate(paramNew(maxNinstance)) - allocate(state(maxNinstance)) - allocate(state0(maxNinstance)) - allocate(dotState(maxNinstance)) - allocate(deltaState(maxNinstance)) + allocate(param(Ninstance)) ! one container of parameters per instance + allocate(paramNew(Ninstance)) + allocate(state(Ninstance)) + allocate(state0(Ninstance)) + allocate(dotState(Ninstance)) + allocate(deltaState(Ninstance)) do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle @@ -303,73 +298,59 @@ subroutine plastic_kinehardening_init endif end do -param(instance)%outputID = prm%outputID + param(instance)%outputID = prm%outputID nslip = prm%totalNslip !-------------------------------------------------------------------------------------------------- ! allocate state arrays - sizeDotState = nSlip & !< crss - + nSlip & !< crss_back - + nSlip !< accumulated (absolute) shear - - sizeDeltaState = nSlip & !< sense of acting shear stress (-1 or +1) - + nSlip & !< backstress at last switch of stress sense - + nSlip !< accumulated shear at last switch of stress sense + NipcMyPhase = count(material_phase == p) ! number of constituents with my phase + sizeDotState = size(['crss ','crss_back', 'accshear ']) * prm%TotalNslip + sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0']) * prm%TotalNslip + sizeState = sizeDotState + sizeDeltaState - sizeState = sizeDotState + sizeDeltaState - NipcMyPhase = count(material_phase == p) ! number of IPCs containing my phase - call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & - nSlip,0_pInt,0_pInt) - plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) - plasticState(p)%offsetDeltaState = sizeDotState + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & + nSlip,0_pInt,0_pInt) + + plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) + plasticState(p)%offsetDeltaState = sizeDotState - endindex = 0_pInt - o = endIndex ! offset of dotstate index relative to state index + startIndex = 1_pInt + endIndex = nSlip + stt%crss => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) + dot%crss => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip - stt%crss => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - dot%crss => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolResistance - -! ............................................. startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip - stt%crss_back => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - dot%crss_back => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolResistance + stt%crss_back => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) + dot%crss_back => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance -! ............................................. startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip - stt%accshear => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - dot%accshear => plasticState(p)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex-o:endIndex-o) = prm%aTolShear + stt%accshear => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) + dot%accshear => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) + plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear !---------------------------------------------------------------------------------------------- !locally define deltaState alias o = endIndex -! ............................................. startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip stt%sense => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) -! ............................................. startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip stt%chi0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - -! ............................................. startIndex = endIndex + 1_pInt endIndex = endIndex + nSlip stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - end associate end do @@ -558,21 +539,17 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) sumGamma = sum(stt%accshear(:,of)) do j = 1_pInt, prm%totalNslip - dot%crss(j,of) = & - dot_product(prm%interaction_SlipSlip(j,:),dot%accshear(:,of)) * & - ( prm%theta1(j) + (prm%theta0(j) - prm%theta1(j) & - + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)) & - *exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & ! V term depending on the harding law - ) + dot%crss(j,of) = dot_product(prm%interaction_SlipSlip(j,:),dot%accshear(:,of)) & + * ( prm%theta1(j) + prm%theta0(j) - prm%theta1(j) & + + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)*exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & + ) enddo - dot%crss_back(:,of) = & - stt%sense(:,of)*dot%accshear(:,of) * & + dot%crss_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & ( prm%theta1_b + & - (prm%theta0_b - prm%theta1_b & - + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& - ) & - *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & - ) ! V term depending on the harding law for back stress + (prm%theta0_b - prm%theta1_b & + + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& + ) *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & + ) end associate @@ -656,34 +633,34 @@ end function plastic_kinehardening_postResults !> @details: Shear rates are calculated only optionally. NOTE: Against the common convention, the !> result (i.e. intent(out)) variables are the last to have the optional arguments at the end !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) +pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) use prec, only: & dNeq0 use math, only: & math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tKinehardeningState), intent(in) :: & - stt - integer(pInt), intent(in) :: & - of - real(pReal), dimension(prm%totalNslip), intent(out) :: & - gdot_pos, & - gdot_neg - real(pReal), dimension(prm%totalNslip), optional, intent(out) :: & - dgdot_dtau_pos, & - dgdot_dtau_neg real(pReal), dimension(3,3), intent(in) :: & Mp + integer(pInt), intent(in) :: & + instance, & + of + real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & + gdot_pos, & + gdot_neg + real(pReal), dimension(paramNew(instance)%totalNslip), optional, intent(out) :: & + dgdot_dtau_pos, & + dgdot_dtau_neg - real(pReal), dimension(prm%totalNslip) :: & + + real(pReal), dimension(paramNew(instance)%totalNslip) :: & tau_pos, & tau_neg integer(pInt) :: i logical :: nonSchmidActive + associate( prm => paramNew(instance), stt => state(instance)) + nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt do i = 1_pInt, prm%totalNslip @@ -723,6 +700,7 @@ pure subroutine kinetics(prm,stt,of,Mp,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dt dgdot_dtau_neg = 0.0_pReal end where endif + end associate end subroutine kinetics From f4cf38fa2273948cbb26dc01992c788d4742fe20 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 21 Dec 2018 23:53:21 +0100 Subject: [PATCH 146/372] implementing C66 rotation for transformation --- src/lattice.f90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 1da02e192..21b575b64 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -1769,8 +1769,8 @@ end function lattice_C66_twin !> @brief Rotated elasticity matrices for transformation in Mandel notation !> ToDo: Completely untested and incomplete and undocumented !-------------------------------------------------------------------------------------------------- -function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & - C_target66,structure_target, & +function lattice_C66_trans(Ntrans,C_parent66, & + structure_target, & CoverA_trans,a_bcc,a_fcc) use prec, only: & tol_math_check @@ -1790,17 +1790,14 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & implicit none integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family character(len=*), intent(in) :: & - structure_target, & !< lattice structure - structure_parent !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C_parent66, C_target66 + structure_target !< lattice structure + real(pReal), dimension(6,6), intent(in) :: C_parent66 real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - - real(pReal), dimension(3,3) :: Q,S + real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S real(pReal) :: a_bcc, a_fcc, CoverA_trans integer(pInt) :: i - if (trim(structure_parent) /= 'hex') write(6,*) "Mist" !-------------------------------------------------------------------------------------------------- ! elasticity matrix of the target phase in cube orientation @@ -1829,7 +1826,10 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_parent, & if (abs(C_target_unrotated66(i,i)) Date: Sat, 22 Dec 2018 00:19:51 +0100 Subject: [PATCH 147/372] poviding stiffness for transformation as function --- src/lattice.f90 | 11 +-- src/plastic_dislotwin.f90 | 147 +++++++++++++++++++------------------- 2 files changed, 81 insertions(+), 77 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 21b575b64..e187dc2a2 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -869,7 +869,8 @@ module lattice lattice_interaction_TwinSlip, & lattice_forestProjection, & lattice_characteristicShear_Twin, & - lattice_C66_twin + lattice_C66_twin, & + lattice_C66_trans contains @@ -1793,6 +1794,7 @@ function lattice_C66_trans(Ntrans,C_parent66, & structure_target !< lattice structure real(pReal), dimension(6,6), intent(in) :: C_parent66 real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 + real(pReal), dimension(3,3,3,3) :: C_target_unrotated real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S real(pReal) :: a_bcc, a_fcc, CoverA_trans @@ -1822,17 +1824,16 @@ function lattice_C66_trans(Ntrans,C_parent66, & write(6,*) "Mist" endif + do i = 1_pInt, 6_pInt if (abs(C_target_unrotated66(i,i)) param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)), & - mse => microstructure(phase_plasticityInstance(p))) + mse => microstructure(phase_plasticityInstance(p)), & + config => config_phase(p)) ! This data is read in already in lattice prm%mu = lattice_mu(p) prm%nu = lattice_nu(p) prm%C66 = lattice_C66(1:6,1:6,p) - structure = config_phase(p)%getString('lattice_structure') + structure = config%getString('lattice_structure') !-------------------------------------------------------------------------------------------------- ! slip related parameters - prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then @@ -303,28 +304,28 @@ subroutine plastic_dislotwin_init prm%fcc_twinNucleationSlipPair = lattice_fcc_twinNucleationSlipPair prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%forestProjectionEdge= lattice_forestProjection (prm%Nslip,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - config_phase(p)%getFloats('interaction_slipslip'), & + config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%rho0 = config_phase(p)%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_0 - prm%rhoDip0 = config_phase(p)%getFloats('rhoedgedip0',requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_dip_0 - prm%v0 = config_phase(p)%getFloats('v0', requiredShape=shape(prm%Nslip)) - prm%burgers_slip = config_phase(p)%getFloats('slipburgers',requiredShape=shape(prm%Nslip)) - prm%Qedge = config_phase(p)%getFloats('qedge', requiredShape=shape(prm%Nslip)) !ToDo: rename (ask Karo) - prm%CLambdaSlip = config_phase(p)%getFloats('clambdaslip',requiredShape=shape(prm%Nslip)) - prm%p = config_phase(p)%getFloats('p_slip', requiredShape=shape(prm%Nslip)) - prm%q = config_phase(p)%getFloats('q_slip', requiredShape=shape(prm%Nslip)) - prm%B = config_phase(p)%getFloats('b', requiredShape=shape(prm%Nslip), & + prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_0 + prm%rhoDip0 = config%getFloats('rhoedgedip0',requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_dip_0 + prm%v0 = config%getFloats('v0', requiredShape=shape(prm%Nslip)) + prm%burgers_slip = config%getFloats('slipburgers',requiredShape=shape(prm%Nslip)) + prm%Qedge = config%getFloats('qedge', requiredShape=shape(prm%Nslip)) !ToDo: rename (ask Karo) + prm%CLambdaSlip = config%getFloats('clambdaslip',requiredShape=shape(prm%Nslip)) + prm%p = config%getFloats('p_slip', requiredShape=shape(prm%Nslip)) + prm%q = config%getFloats('q_slip', requiredShape=shape(prm%Nslip)) + prm%B = config%getFloats('b', requiredShape=shape(prm%Nslip), & defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) - prm%tau_peierls = config_phase(p)%getFloats('tau_peierls',requiredShape=shape(prm%Nslip), & + prm%tau_peierls = config%getFloats('tau_peierls',requiredShape=shape(prm%Nslip), & defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) - prm%CEdgeDipMinDistance = config_phase(p)%getFloat('cedgedipmindistance') + prm%CEdgeDipMinDistance = config%getFloat('cedgedipmindistance') ! expand: family => system prm%rho0 = math_expand(prm%rho0, prm%Nslip) @@ -356,33 +357,33 @@ subroutine plastic_dislotwin_init !-------------------------------------------------------------------------------------------------- ! twin related parameters - prm%Ntwin = config_phase(p)%getInts('ntwin', defaultVal=emptyIntArray) + prm%Ntwin = config%getInts('ntwin', defaultVal=emptyIntArray) prm%totalNtwin = sum(prm%Ntwin) if (prm%totalNtwin > 0_pInt) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_TwinTwin = lattice_interaction_TwinTwin(prm%Ntwin,& - config_phase(p)%getFloats('interaction_twintwin'), & + config%getFloats('interaction_twintwin'), & structure(1:3)) - prm%burgers_twin = config_phase(p)%getFloats('twinburgers') - prm%twinsize = config_phase(p)%getFloats('twinsize') - prm%r = config_phase(p)%getFloats('r_twin') + prm%burgers_twin = config%getFloats('twinburgers') + prm%twinsize = config%getFloats('twinsize') + prm%r = config%getFloats('r_twin') - prm%xc_twin = config_phase(p)%getFloat('xc_twin') - prm%L0_twin = config_phase(p)%getFloat('l0_twin') - prm%MaxTwinFraction = config_phase(p)%getFloat('maxtwinfraction') ! ToDo: only used in postResults - prm%Cthresholdtwin = config_phase(p)%getFloat('cthresholdtwin', defaultVal=0.0_pReal) - prm%Cmfptwin = config_phase(p)%getFloat('cmfptwin', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%xc_twin = config%getFloat('xc_twin') + prm%L0_twin = config%getFloat('l0_twin') + prm%MaxTwinFraction = config%getFloat('maxtwinfraction') ! ToDo: only used in postResults + prm%Cthresholdtwin = config%getFloat('cthresholdtwin', defaultVal=0.0_pReal) + prm%Cmfptwin = config%getFloat('cmfptwin', defaultVal=0.0_pReal) ! ToDo: How to handle that??? prm%shear_twin = lattice_characteristicShear_Twin(prm%Ntwin,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%C66_twin = lattice_C66_twin(prm%Ntwin,prm%C66,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) if (.not. prm%fccTwinTransNucleation) then - prm%Ndot0_twin = config_phase(p)%getFloats('ndot0_twin') + prm%Ndot0_twin = config%getFloats('ndot0_twin') prm%Ndot0_twin = math_expand(prm%Ndot0_twin,prm%Ntwin) endif @@ -399,29 +400,36 @@ subroutine plastic_dislotwin_init !-------------------------------------------------------------------------------------------------- ! transformation related parameters - prm%Ntrans = config_phase(p)%getInts('ntrans', defaultVal=emptyIntArray) + prm%Ntrans = config%getInts('ntrans', defaultVal=emptyIntArray) prm%totalNtrans = sum(prm%Ntrans) if (prm%totalNtrans > 0_pInt) then - prm%burgers_trans = config_phase(p)%getFloats('transburgers') + prm%burgers_trans = config%getFloats('transburgers') prm%burgers_trans = math_expand(prm%burgers_trans,prm%Ntrans) - prm%Cthresholdtrans = config_phase(p)%getFloat('cthresholdtrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%transStackHeight = config_phase(p)%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%Cmfptrans = config_phase(p)%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%deltaG = config_phase(p)%getFloat('deltag') - prm%xc_trans = config_phase(p)%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%L0_trans = config_phase(p)%getFloat('l0_trans') + prm%Cthresholdtrans = config%getFloat('cthresholdtrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%transStackHeight = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%Cmfptrans = config%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%deltaG = config%getFloat('deltag') + prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%L0_trans = config%getFloat('l0_trans') prm%interaction_TransTrans = lattice_interaction_TransTrans(prm%Ntrans,& - config_phase(p)%getFloats('interaction_transtrans'), & + config%getFloats('interaction_transtrans'), & structure(1:3)) + + prm%C66_trans = lattice_C66_trans(prm%Ntrans,prm%C66, & + config%getString('trans_lattice_structure'), & + 0.0_pReal, & + config%getFloat('a_bcc', defaultVal=0.0_pReal), & + config%getFloat('a_fcc', defaultVal=0.0_pReal)) + if (lattice_structure(p) /= LATTICE_fcc_ID) then - prm%Ndot0_trans = config_phase(p)%getFloats('ndot0_trans') + prm%Ndot0_trans = config%getFloats('ndot0_trans') prm%Ndot0_trans = math_expand(prm%Ndot0_trans,prm%Ntrans) endif - prm%lamellarsizePerTransSystem = config_phase(p)%getFloats('lamellarsize') + prm%lamellarsizePerTransSystem = config%getFloats('lamellarsize') prm%lamellarsizePerTransSystem = math_expand(prm%lamellarsizePerTransSystem,prm%Ntrans) - prm%s = config_phase(p)%getFloats('s_trans',defaultVal=[0.0_pReal]) + prm%s = config%getFloats('s_trans',defaultVal=[0.0_pReal]) prm%s = math_expand(prm%s,prm%Ntrans) else allocate(prm%lamellarsizePerTransSystem(0)) @@ -429,48 +437,48 @@ subroutine plastic_dislotwin_init endif if (sum(prm%Ntwin) > 0_pInt .or. prm%totalNtrans > 0_pInt) then - prm%SFE_0K = config_phase(p)%getFloat('sfe_0k') - prm%dSFE_dT = config_phase(p)%getFloat('dsfe_dt') - prm%VcrossSlip = config_phase(p)%getFloat('vcrossslip') + prm%SFE_0K = config%getFloat('sfe_0k') + prm%dSFE_dT = config%getFloat('dsfe_dt') + prm%VcrossSlip = config%getFloat('vcrossslip') endif if (prm%totalNslip > 0_pInt .and. prm%totalNtwin > 0_pInt) then prm%interaction_SlipTwin = lattice_interaction_SlipTwin(prm%Nslip,prm%Ntwin,& - config_phase(p)%getFloats('interaction_sliptwin'), & + config%getFloats('interaction_sliptwin'), & structure(1:3)) prm%interaction_TwinSlip = lattice_interaction_TwinSlip(prm%Ntwin,prm%Nslip,& - config_phase(p)%getFloats('interaction_twinslip'), & + config%getFloats('interaction_twinslip'), & structure(1:3)) if (prm%fccTwinTransNucleation .and. prm%totalNtwin > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntwin is [6,6] endif if (prm%totalNslip > 0_pInt .and. prm%totalNtrans > 0_pInt) then prm%interaction_SlipTrans = lattice_interaction_SlipTrans(prm%Nslip,prm%Ntrans,& - config_phase(p)%getFloats('interaction_sliptrans'), & + config%getFloats('interaction_sliptrans'), & structure(1:3)) if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] endif - prm%aTolRho = config_phase(p)%getFloat('atol_rho', defaultVal=0.0_pReal) - prm%aTolTwinFrac = config_phase(p)%getFloat('atol_twinfrac', defaultVal=0.0_pReal) - prm%aTolTransFrac = config_phase(p)%getFloat('atol_transfrac', defaultVal=0.0_pReal) + prm%aTolRho = config%getFloat('atol_rho', defaultVal=0.0_pReal) + prm%aTolTwinFrac = config%getFloat('atol_twinfrac', defaultVal=0.0_pReal) + prm%aTolTransFrac = config%getFloat('atol_transfrac', defaultVal=0.0_pReal) - prm%CAtomicVolume = config_phase(p)%getFloat('catomicvolume') - prm%GrainSize = config_phase(p)%getFloat('grainsize') + prm%CAtomicVolume = config%getFloat('catomicvolume') + prm%GrainSize = config%getFloat('grainsize') - prm%D0 = config_phase(p)%getFloat('d0') - prm%Qsd = config_phase(p)%getFloat('qsd') - prm%SolidSolutionStrength = config_phase(p)%getFloat('solidsolutionstrength') - if (config_phase(p)%keyExists('dipoleformationfactor')) call IO_error(1,ext_msg='use /nodipoleformation/') - prm%dipoleformation = .not. config_phase(p)%keyExists('/nodipoleformation/') - prm%sbVelocity = config_phase(p)%getFloat('shearbandvelocity',defaultVal=0.0_pReal) + prm%D0 = config%getFloat('d0') + prm%Qsd = config%getFloat('qsd') + prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') + if (config%keyExists('dipoleformationfactor')) call IO_error(1,ext_msg='use /nodipoleformation/') + prm%dipoleformation = .not. config%keyExists('/nodipoleformation/') + prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal) if (prm%sbVelocity > 0.0_pReal) then - prm%sbResistance = config_phase(p)%getFloat('shearbandresistance') - prm%sbQedge = config_phase(p)%getFloat('qedgepersbsystem') - prm%pShearBand = config_phase(p)%getFloat('p_shearband') - prm%qShearBand = config_phase(p)%getFloat('q_shearband') + prm%sbResistance = config%getFloat('shearbandresistance') + prm%sbQedge = config%getFloat('qedgepersbsystem') + prm%pShearBand = config%getFloat('p_shearband') + prm%qShearBand = config%getFloat('q_shearband') endif !if (Ndot0PerTwinFamily(f,p) < 0.0_pReal) & @@ -511,7 +519,7 @@ subroutine plastic_dislotwin_init prm%qShearBand <= 0.0_pReal) & call IO_error(211_pInt,el=p,ext_msg='qShearBand ('//PLASTICITY_DISLOTWIN_label//')') - outputs = config_phase(p)%getStrings('(output)', defaultVal=emptyStringArray) + outputs = config%getStrings('(output)', defaultVal=emptyStringArray) allocate(prm%outputID(0)) do i= 1_pInt, size(outputs) outputID = undefined_ID @@ -608,7 +616,6 @@ subroutine plastic_dislotwin_init ! DEPRECATED BEGIN - allocate(prm%C66_trans(6,6,prm%totalNtrans) ,source=0.0_pReal) allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) i = 0_pInt transFamiliesLoop: do f = 1_pInt,size(prm%Ntrans,1) @@ -616,14 +623,10 @@ subroutine plastic_dislotwin_init transSystemsLoop: do j = 1_pInt,prm%Ntrans(f) i = i + 1_pInt prm%Schmid_trans(1:3,1:3,i) = lattice_Strans(1:3,1:3,sum(lattice_Ntranssystem(1:f-1,p))+j,p) - !* Rotate trans elasticity matrices - index_otherFamily = sum(lattice_NtransSystem(1:f-1_pInt,p)) ! index in full lattice trans list - prm%C66_trans(1:6,1:6,index_myFamily+j) = & - math_Mandel3333to66(math_rotate_forward3333(lattice_trans_C3333(1:3,1:3,1:3,1:3,p),& - lattice_Qtrans(1:3,1:3,index_otherFamily+j,p))) enddo transSystemsLoop enddo transFamiliesLoop -! DEPRECATED END +! DEPRECATED END + startIndex=1_pInt endIndex=prm%totalNslip From e083520c7361249add0584ace031756358344a6f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 07:49:52 +0100 Subject: [PATCH 148/372] trans systems now handled centrally remove inactive (= untested) definitions. --- src/lattice.f90 | 438 ++++++++++++-------------------------- src/plastic_dislotwin.f90 | 31 ++- 2 files changed, 150 insertions(+), 319 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index e187dc2a2..b4d0fa8dd 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -32,18 +32,13 @@ module lattice real(pReal), allocatable, dimension(:,:,:,:), protected, public :: & lattice_Sslip_v, & !< Mandel notation of lattice_Sslip - lattice_Scleavage_v, & !< Mandel notation of lattice_Scleavege - lattice_Qtrans, & !< Total rotation: Q = R*B - lattice_Strans !< Eigendeformation tensor for phase transformation + lattice_Scleavage_v !< Mandel notation of lattice_Scleavege real(pReal), allocatable, dimension(:,:,:), protected, public :: & lattice_sn, & !< normal direction of slip system lattice_st, & !< sd x sn lattice_sd !< slip direction of slip system - real(pReal), allocatable, dimension(:,:), protected, private :: & - lattice_shearTrans !< characteristic transformation shear - integer(pInt), allocatable, dimension(:), protected, public :: & lattice_NnonSchmid !< total # of non-Schmid contributions for each structure ! END DEPRECATED @@ -70,7 +65,7 @@ module lattice LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & - LATTICE_fcc_systemSlip = reshape(real([& + LATTICE_FCC_SYSTEMSLIP = reshape(real([& ! Slip direction Plane normal ! SCHMID-BOAS notation 0, 1,-1, 1, 1, 1, & ! B2 -1, 0, 1, 1, 1, 1, & ! B4 @@ -116,22 +111,6 @@ module lattice character(len=*), dimension(1), parameter, public :: LATTICE_FCC_TWINFAMILY_NAME = & ['<-2 1 1>{1 1 1}'] - real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter, private :: & - LATTICE_fccTohex_systemTrans = reshape(real( [& - -2, 1, 1, 1, 1, 1, & - 1,-2, 1, 1, 1, 1, & - 1, 1,-2, 1, 1, 1, & - 2,-1, 1, -1,-1, 1, & - -1, 2, 1, -1,-1, 1, & - -1,-1,-2, -1,-1, 1, & - -2,-1,-1, 1,-1,-1, & - 1, 2,-1, 1,-1,-1, & - 1,-1, 2, 1,-1,-1, & - 2, 1,-1, -1, 1,-1, & - -1,-2,-1, -1, 1,-1, & - -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) - integer(pInt), dimension(2_pInt,LATTICE_FCC_NTWIN), parameter, public :: & LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape(int( [& @@ -185,95 +164,6 @@ module lattice !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - real(pReal), dimension(LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_fccTohex_shearTrans = sqrt(1.0_pReal/8.0_pReal) - - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_FCCTOBCC_SYSTEMTRANS = reshape([& - 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) - 0.0, 1.0, 0.0, -10.26, & - 0.0, 0.0, 1.0, 10.26, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 1.0, 0.0, 0.0, -10.26, & - 0.0, 0.0, 1.0, 10.26, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 1.0, 0.0, 0.0, -10.26, & - 0.0, 1.0, 0.0, 10.26, & - 0.0, 1.0, 0.0, -10.26 & - ],shape(LATTICE_FCCTOBCC_SYSTEMTRANS)) - - integer(pInt), dimension(9,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_FCCTOBCC_BAINVARIANT = reshape(int( [& - 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0 & - ],pInt),shape(LATTICE_FCCTOBCC_BAINVARIANT)) - - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & - LATTICE_FCCTOBCC_BAINROT = reshape([& - 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0 & - ],shape(LATTICE_FCCTOBCC_BAINROT)) - - real(pReal), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter, private :: & ! Matrix for projection of shear from slip system to fault-band (twin) systems - LATTICE_FCCTOBCC_PROJECTIONTRANS = reshape(real([& ! For ns = nt = nr - 0, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - -1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 1,-1, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, -1, 0, 1, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 1,-1, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 1,-1, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, -1, 0, 1, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 1,-1, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, 1, & - 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1, 0 & - ],pReal),shape(LATTICE_FCCTOBCC_PROJECTIONTRANS),order=[2,1]) - - real(pReal), parameter, private :: & - LATTICE_fccTobcc_projectionTransFactor = sqrt(3.0_pReal/4.0_pReal) - - real(pReal), parameter, public :: & - LATTICE_fccTobcc_shearCritTrans = 0.0224 - - integer(pInt), dimension(2_pInt,LATTICE_fcc_Ntrans), parameter, public :: & - LATTICE_FCCTOBCC_TRANSNUCLEATIONTWINPAIR = reshape(int( [& - 4, 7, & - 1, 10, & - 1, 4, & - 7, 10, & - 2, 8, & - 5, 11, & - 8, 11, & - 2, 5, & - 6, 12, & - 3, 9, & - 3, 12, & - 6, 9 & - ],pInt),shape(LATTICE_FCCTOBCC_TRANSNUCLEATIONTWINPAIR)) - real(pReal), dimension(3+3,LATTICE_fcc_Ncleavage), parameter, private :: & LATTICE_fcc_systemCleavage = reshape(real([& ! Cleavage direction Plane normal @@ -332,31 +222,6 @@ module lattice 1,-1, 1, -1, 1, 2, & -1, 1, 1, 1,-1, 2, & 1, 1, 1, 1, 1,-2 & - ! Slip system <111>{123} - ! 1, 1,-1, 1, 2, 3, & - ! 1,-1, 1, -1, 2, 3, & - ! -1, 1, 1, 1,-2, 3, & - ! 1, 1, 1, 1, 2,-3, & - ! 1,-1, 1, 1, 3, 2, & - ! 1, 1,-1, -1, 3, 2, & - ! 1, 1, 1, 1,-3, 2, & - ! -1, 1, 1, 1, 3,-2, & - ! 1, 1,-1, 2, 1, 3, & - ! 1,-1, 1, -2, 1, 3, & - ! -1, 1, 1, 2,-1, 3, & - ! 1, 1, 1, 2, 1,-3, & - ! 1,-1, 1, 2, 3, 1, & - ! 1, 1,-1, -2, 3, 1, & - ! 1, 1, 1, 2,-3, 1, & - ! -1, 1, 1, 2, 3,-1, & - ! -1, 1, 1, 3, 1, 2, & - ! 1, 1, 1, -3, 1, 2, & - ! 1, 1,-1, 3,-1, 2, & - ! 1,-1, 1, 3, 1,-2, & - ! -1, 1, 1, 3, 2, 1, & - ! 1, 1, 1, -3, 2, 1, & - ! 1, 1,-1, 3,-2, 1, & - ! 1,-1, 1, 3, 2,-1 & ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) character(len=*), dimension(2), parameter, public :: LATTICE_BCC_SLIPFAMILY_NAME = & @@ -581,10 +446,7 @@ module lattice 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,36,37,37, & 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & - ! - ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) - - + ],pInt),shape(LATTICE_HEX_INTERACTIONSLIPSLIP),order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) real(pReal), dimension(4+4,LATTICE_hex_Ncleavage), parameter, private :: & @@ -755,9 +617,9 @@ module lattice 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, & 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, & 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169 & - ],pInt),[lattice_bct_Nslip,lattice_bct_Nslip],order=[2,1]) + !-------------------------------------------------------------------------------------------------- ! isotropic integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & @@ -774,13 +636,14 @@ module lattice 1, 0, 0, 0, 0, 1 & ],pReal),[ 3_pInt + 3_pInt,LATTICE_iso_Ncleavage]) + !-------------------------------------------------------------------------------------------------- ! orthorhombic integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & - LATTICE_ort_NcleavageSystem = int([1, 1, 1],pInt) !< # of cleavage systems per family for ortho + LATTICE_ort_NcleavageSystem = int([1, 1, 1],pInt) !< # of cleavage systems per family for ortho integer(pInt), parameter, private :: & - LATTICE_ort_Ncleavage = sum(lattice_ort_NcleavageSystem) !< total # of cleavage systems for ortho + LATTICE_ort_Ncleavage = sum(lattice_ort_NcleavageSystem) !< total # of cleavage systems for ortho real(pReal), dimension(3+3,LATTICE_ort_Ncleavage), parameter, private :: & LATTICE_ort_systemCleavage = reshape(real([& @@ -795,19 +658,16 @@ module lattice LATTICE_maxNslip = max(LATTICE_FCC_NSLIP,LATTICE_BCC_NSLIP,LATTICE_HEX_NSLIP, & LATTICE_bct_Nslip), & !< max # of slip systems over lattice structures LATTICE_maxNnonSchmid = LATTICE_bcc_NnonSchmid, & !< max # of non-Schmid contributions over lattice structures - LATTICE_maxNtrans = LATTICE_fcc_Ntrans, & !< max # of transformation systems over lattice structures LATTICE_maxNcleavage = max(LATTICE_fcc_Ncleavage,LATTICE_bcc_Ncleavage, & LATTICE_hex_Ncleavage, & - LATTICE_iso_Ncleavage,LATTICE_ort_Ncleavage), & !< max # of cleavage systems over lattice structures + LATTICE_iso_Ncleavage,LATTICE_ort_Ncleavage), & !< max # of cleavage systems over lattice structures LATTICE_maxNinteraction = 182_pInt !END DEPRECATED - real(pReal), dimension(:,:,:), allocatable, private :: & - temp66 real(pReal), dimension(:,:,:), allocatable, public, protected :: & lattice_C66 real(pReal), dimension(:,:,:,:,:), allocatable, public, protected :: & - lattice_C3333, lattice_trans_C3333 + lattice_C3333 real(pReal), dimension(:), allocatable, public, protected :: & lattice_mu, lattice_nu @@ -860,6 +720,8 @@ module lattice LATTICE_hex_ID, & lattice_SchmidMatrix_slip, & lattice_SchmidMatrix_twin, & + lattice_SchmidMatrix_trans, & + lattice_SchmidMatrix_cleavage, & lattice_nonSchmidMatrix, & lattice_interaction_SlipSlip, & lattice_interaction_TwinTwin, & @@ -896,10 +758,8 @@ subroutine lattice_init integer(pInt) :: i,p real(pReal), dimension(:), allocatable :: & temp, & - CoverA, & !< c/a ratio for low symmetry type lattice - CoverA_trans, & !< c/a ratio for transformed hex type lattice - a_fcc, & !< lattice parameter a for fcc austenite - a_bcc !< lattice paramater a for bcc martensite + CoverA !< c/a ratio for low symmetry type lattice + write(6,'(/,a)') ' <<<+- lattice init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -910,9 +770,8 @@ subroutine lattice_init allocate(lattice_structure(Nphases),source = LATTICE_undefined_ID) allocate(trans_lattice_structure(Nphases),source = LATTICE_undefined_ID) allocate(lattice_C66(6,6,Nphases), source=0.0_pReal) - allocate(temp66(6,6,Nphases), source=0.0_pReal) allocate(lattice_C3333(3,3,3,3,Nphases), source=0.0_pReal) - allocate(lattice_trans_C3333(3,3,3,3,Nphases), source=0.0_pReal) + allocate(lattice_thermalExpansion33 (3,3,3,Nphases), source=0.0_pReal) ! constant, linear, quadratic coefficients allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) @@ -948,14 +807,8 @@ subroutine lattice_init allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) - allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) - allocate(CoverA(Nphases),source=0.0_pReal) - allocate(CoverA_trans(Nphases),source=0.0_pReal) - allocate(a_fcc(Nphases),source=0.0_pReal) - allocate(a_bcc(Nphases),source=0.0_pReal) + allocate(lattice_sd(3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_st(3,lattice_maxNslip,Nphases),source=0.0_pReal) @@ -998,20 +851,8 @@ subroutine lattice_init lattice_C66(5,5,p) = config_phase(p)%getFloat('c55',defaultVal=0.0_pReal) lattice_C66(6,6,p) = config_phase(p)%getFloat('c66',defaultVal=0.0_pReal) - temp66(1,1,p) = config_phase(p)%getFloat('c11_trans',defaultVal=0.0_pReal) - temp66(1,2,p) = config_phase(p)%getFloat('c12_trans',defaultVal=0.0_pReal) - temp66(1,3,p) = config_phase(p)%getFloat('c13_trans',defaultVal=0.0_pReal) - temp66(2,2,p) = config_phase(p)%getFloat('c22_trans',defaultVal=0.0_pReal) - temp66(2,3,p) = config_phase(p)%getFloat('c23_trans',defaultVal=0.0_pReal) - temp66(3,3,p) = config_phase(p)%getFloat('c33_trans',defaultVal=0.0_pReal) - temp66(4,4,p) = config_phase(p)%getFloat('c44_trans',defaultVal=0.0_pReal) - temp66(5,5,p) = config_phase(p)%getFloat('c55_trans',defaultVal=0.0_pReal) - temp66(6,6,p) = config_phase(p)%getFloat('c66_trans',defaultVal=0.0_pReal) CoverA(p) = config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal) - CoverA_trans(p) = config_phase(p)%getFloat('c/a_trans',defaultVal=0.0_pReal) - a_fcc(p) = config_phase(p)%getFloat('a_fcc',defaultVal=0.0_pReal) - a_bcc(p) = config_phase(p)%getFloat('a_bcc',defaultVal=0.0_pReal) lattice_thermalConductivity33(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultVal=0.0_pReal) lattice_thermalConductivity33(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultVal=0.0_pReal) @@ -1062,7 +903,7 @@ subroutine lattice_init .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131_pInt,el=i) ! checking physical significance of c/a if ((CoverA(i) > 2.0_pReal) & .and. lattice_structure(i) == LATTICE_bct_ID) call IO_error(131_pInt,el=i) ! checking physical significance of c/a - call lattice_initializeStructure(i, CoverA(i), CoverA_trans(i), a_fcc(i), a_bcc(i)) + call lattice_initializeStructure(i, CoverA(i)) enddo end subroutine lattice_init @@ -1071,7 +912,7 @@ end subroutine lattice_init !-------------------------------------------------------------------------------------------------- !> @brief !!!!!!!DEPRECTATED!!!!!! !-------------------------------------------------------------------------------------------------- -subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) +subroutine lattice_initializeStructure(myPhase,CoverA) use prec, only: & tol_math_check use math, only: & @@ -1094,30 +935,18 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) implicit none integer(pInt), intent(in) :: myPhase real(pReal), intent(in) :: & - CoverA, & - CoverA_trans, & - a_fcc, & - a_bcc + CoverA real(pReal), dimension(3) :: & sdU, snU, & np, nn - real(pReal), dimension(3,3) :: & - sstr, sdtr, sttr real(pReal), dimension(3,lattice_maxNslip) :: & sd, sn real(pReal), dimension(3,3,2,lattice_maxNnonSchmid,lattice_maxNslip) :: & sns - real(pReal), dimension(lattice_maxNtrans) :: & - trs - real(pReal), dimension(3,lattice_maxNtrans) :: & - xtr, ytr, ztr - real(pReal), dimension(3,3,lattice_maxNtrans) :: & - Rtr, Utr, Btr, Qtr, Str integer(pInt) :: & - i,j, & - myNslip, myNtrans, myNcleavage - real(pReal) :: c11bar, c12bar, c13bar, c14bar, c33bar, c44bar, A, B + j, i, & + myNslip, myNcleavage lattice_C66(1:6,1:6,myPhase) = lattice_symmetrizeC66(lattice_structure(myPhase),& lattice_C66(1:6,1:6,myPhase)) @@ -1138,44 +967,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) call IO_error(135_pInt,el=i,ip=myPhase,ext_msg='matrix diagonal "el"ement of phase "ip"') enddo -! Elasticity matrices for transformed phase - select case(lattice_structure(myPhase)) - case (LATTICE_fcc_ID) - select case(trans_lattice_structure(myPhase)) - case (LATTICE_bcc_ID) - lattice_trans_C3333(1:3,1:3,1:3,1:3,myPhase) = lattice_C3333(1:3,1:3,1:3,1:3,myPhase) - temp66(1:6,1:6,myPhase) = math_Mandel3333to66(lattice_trans_C3333(1:3,1:3,1:3,1:3,myPhase)) - do i = 1_pInt, 6_pInt - if (abs(temp66(i,i,myPhase))bcc transformation') - enddo - case (LATTICE_hex_ID) - c11bar = (lattice_C66(1,1,myPhase) + lattice_C66(1,2,myPhase) + 2.0_pReal*lattice_C66(4,4,myPhase))/2.0_pReal - c12bar = (lattice_C66(1,1,myPhase) + 5.0_pReal*lattice_C66(1,2,myPhase) - 2.0_pReal*lattice_C66(4,4,myPhase))/6.0_pReal - c33bar = (lattice_C66(1,1,myPhase) + 2.0_pReal*lattice_C66(1,2,myPhase) + 4.0_pReal*lattice_C66(4,4,myPhase))/3.0_pReal - c13bar = (lattice_C66(1,1,myPhase) + 2.0_pReal*lattice_C66(1,2,myPhase) - 2.0_pReal*lattice_C66(4,4,myPhase))/3.0_pReal - c44bar = (lattice_C66(1,1,myPhase) - lattice_C66(1,2,myPhase) + lattice_C66(4,4,myPhase))/3.0_pReal - c14bar = (lattice_C66(1,1,myPhase) - lattice_C66(1,2,myPhase) - 2.0_pReal*lattice_C66(4,4,myPhase)) & - /(3.0_pReal*sqrt(2.0_pReal)) - A = c14bar**(2.0_pReal)/c44bar - B = c14bar**(2.0_pReal)/(0.5_pReal*(c11bar - c12bar)) - temp66(1,1,myPhase) = c11bar - A - temp66(1,2,myPhase) = c12bar + A - temp66(1,3,myPhase) = c13bar - temp66(3,3,myPhase) = c33bar - temp66(4,4,myPhase) = c44bar - B - - temp66(1:6,1:6,myPhase) = lattice_symmetrizeC66(trans_lattice_structure(myPhase),& - temp66(1:6,1:6,myPhase)) - lattice_trans_C3333(1:3,1:3,1:3,1:3,myPhase) = math_Voigt66to3333(temp66(1:6,1:6,myPhase)) - temp66(1:6,1:6,myPhase) = math_Mandel3333to66(lattice_trans_C3333(1:3,1:3,1:3,1:3,myPhase)) - do i = 1_pInt, 6_pInt - if (abs(temp66(i,i,myPhase))hex transformation') - enddo - end select - end select - forall (i = 1_pInt:3_pInt) & lattice_thermalExpansion33 (1:3,1:3,i,myPhase) = lattice_symmetrize33(lattice_structure(myPhase),& lattice_thermalExpansion33 (1:3,1:3,i,myPhase)) @@ -1195,7 +986,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) lattice_hydrogenfluxMobility33 (1:3,1:3,myPhase) = lattice_symmetrize33(lattice_structure(myPhase),& lattice_hydrogenfluxMobility33 (1:3,1:3,myPhase)) myNslip = 0_pInt - myNtrans = 0_pInt myNcleavage = 0_pInt select case(lattice_structure(myPhase)) @@ -1203,7 +993,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) ! fcc case (LATTICE_fcc_ID) myNslip = LATTICE_FCC_NSLIP - myNtrans = lattice_fcc_Ntrans myNcleavage = lattice_fcc_Ncleavage lattice_NslipSystem (1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem @@ -1217,51 +1006,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) sn(1:3,i) = lattice_fcc_systemSlip(4:6,i) enddo - ! Phase transformation - select case(trans_lattice_structure(myPhase)) - case (LATTICE_bcc_ID) ! fcc to bcc transformation - do i = 1_pInt,myNtrans - Rtr(1:3,1:3,i) = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation - lattice_fccTobcc_systemTrans(4,i)*INRAD) - Btr(1:3,1:3,i) = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system - lattice_fccTobcc_bainRot(4,i)*INRAD) - xtr(1:3,i) = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) - ytr(1:3,i) = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - ztr(1:3,i) = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) - Utr(1:3,1:3,i) = 0.0_pReal ! Bain deformation - if ((a_fcc > 0.0_pReal) .and. (a_bcc > 0.0_pReal)) then - Utr(1:3,1:3,i) = (a_bcc/a_fcc)*math_tensorproduct33(xtr(1:3,i), xtr(1:3,i)) + & - sqrt(2.0_pReal)*(a_bcc/a_fcc)*math_tensorproduct33(ytr(1:3,i), ytr(1:3,i)) + & - sqrt(2.0_pReal)*(a_bcc/a_fcc)*math_tensorproduct33(ztr(1:3,i), ztr(1:3,i)) - endif - Qtr(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), Btr(1:3,1:3,i)) - Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), Utr(1:3,1:3,i)) - MATH_I3 - enddo - case (LATTICE_hex_ID) - sstr(1:3,1:3) = MATH_I3 - sstr(1,3) = sqrt(2.0_pReal)/4.0_pReal - sdtr(1:3,1:3) = MATH_I3 - if (CoverA_trans > 1.0_pReal .and. CoverA_trans < 2.0_pReal) then - sdtr(3,3) = CoverA_trans/sqrt(8.0_pReal/3.0_pReal) - endif - sttr = math_mul33x33(sdtr, sstr) - do i = 1_pInt,myNtrans - xtr(1:3,i) = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) - ztr(1:3,i) = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) - ytr(1:3,i) = -math_crossproduct(xtr(1:3,i), ztr(1:3,i)) - Rtr(1:3,1,i) = xtr(1:3,i) - Rtr(1:3,2,i) = ytr(1:3,i) - Rtr(1:3,3,i) = ztr(1:3,i) - Qtr(1:3,1:3,i) = Rtr(1:3,1:3,i) - Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), math_mul33x33(sttr, transpose(Rtr(1:3,1:3,i)))) - Str(1:3,1:3,i) = Str(1:3,1:3,i) - MATH_I3 - trs(i) = lattice_fccTohex_shearTrans(i) - enddo - case default - Qtr = 0.0_pReal - Str = 0.0_pReal - end select - !-------------------------------------------------------------------------------------------------- ! bcc @@ -1378,11 +1122,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) math_Mandel33to6(math_symmetric33(lattice_Sslip(1:3,1:3,j,i,myPhase))) enddo enddo - do i = 1_pInt,myNtrans - lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) - lattice_Strans(1:3,1:3,i,myPhase) = Str(1:3,1:3,i) - lattice_shearTrans(i,myPhase) = trs(i) - enddo do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure do j = 1_pInt,3_pInt @@ -1830,7 +1569,7 @@ function lattice_C66_trans(Ntrans,C_parent66, & call IO_error(135_pInt,el=i,ext_msg='matrix diagonal "el"ement in transformation') enddo C_target_unrotated = math_Mandel66to3333(C_target_unrotated66) - call lattice_Trans(Q,S,Ntrans,CoverA_trans,a_fcc,a_bcc) + call buildTransformationSystem(Q,S,Ntrans,CoverA_trans,a_fcc,a_bcc) do i = 1, sum(Ntrans) lattice_C66_trans(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(C_target_unrotated,Q(1:3,1:3,i))) @@ -2463,6 +2202,38 @@ function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) end function lattice_SchmidMatrix_twin +!-------------------------------------------------------------------------------------------------- +!> @brief Schmid matrix for twinning +!> details only active twin systems are considered +!-------------------------------------------------------------------------------------------------- +function lattice_SchmidMatrix_trans(Ntrans,structure_target,cOverA,a_bcc,a_fcc) result(SchmidMatrix) + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_tensorproduct33 + + implicit none + integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix + + integer(pInt) :: i + + character(len=*), intent(in) :: & + structure_target !< lattice structure + + real(pReal), dimension(3,3,sum(Ntrans)) :: devNull + real(pReal) :: a_bcc, a_fcc +! ToDo: Error checking!!!!!!!!!!!!!!!!!!! + call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) + + +end function lattice_SchmidMatrix_trans + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for cleavage !> details only active cleavage systems are considered @@ -2680,12 +2451,16 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) end function buildCoordinateSystem + !-------------------------------------------------------------------------------------------------- !> @brief Helper function to define transformation systems -! Needed for Schmid_trans + C66_trans -! ToDo: completely untested and uncommented +! Needed to calculate Schmid matrix and rotated stiffness matrices. +! @details: set c/a = 0.0 for fcc -> bcc transformation +! set a_bcc = 0.0 for fcc -> bcc transformation !-------------------------------------------------------------------------------------------------- -subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) +subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) + use prec, only: & + dEq0 use math, only: & math_crossproduct, & math_tensorproduct33, & @@ -2701,30 +2476,93 @@ subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) integer(pInt), dimension(:), intent(in) :: & Ntrans real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & - S, Q - real(pReal), intent(in), optional :: & - cOverA, & - a_fcc, & - a_bcc + Q, & !< Total rotation: Q = R*B + S !< Eigendeformation tensor for phase transformation + real(pReal), intent(in) :: & + cOverA, & !< c/a for target hex structure + a_bcc, & !< lattice parameter a for target bcc structure + a_fcc !< lattice parameter a for parent fcc structure real(pReal), dimension(3,3) :: & - R, & - U, & ! Bain deformation - B, & + R, & !< Pitsch rotation + U, & !< Bain deformation + B, & !< Rotation of fcc to Bain coordinate system ss, sd real(pReal), dimension(3) :: & x, y, z integer(pInt) :: & i + real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter :: & + LATTICE_FCCTOHEX_SYSTEMTRANS = reshape(real( [& + -2, 1, 1, 1, 1, 1, & + 1,-2, 1, 1, 1, 1, & + 1, 1,-2, 1, 1, 1, & + 2,-1, 1, -1,-1, 1, & + -1, 2, 1, -1,-1, 1, & + -1,-1,-2, -1,-1, 1, & + -2,-1,-1, 1,-1,-1, & + 1, 2,-1, 1,-1,-1, & + 1,-1, 2, 1,-1,-1, & + 2, 1,-1, -1, 1,-1, & + -1,-2,-1, -1, 1,-1, & + -1, 1, 2, -1, 1,-1 & + ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_SYSTEMTRANS = reshape([& + 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) + 0.0, 1.0, 0.0, -10.26, & + 0.0, 0.0, 1.0, 10.26, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 1.0, 0.0, 0.0, -10.26, & + 0.0, 0.0, 1.0, 10.26, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 1.0, 0.0, 0.0, -10.26, & + 0.0, 1.0, 0.0, 10.26, & + 0.0, 1.0, 0.0, -10.26 & + ],shape(LATTICE_FCCTOBCC_SYSTEMTRANS)) + + integer(pInt), dimension(9,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINVARIANT = reshape(int( [& + 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0 & + ],pInt),shape(LATTICE_FCCTOBCC_BAINVARIANT)) + + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINROT = reshape([& + 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0 & + ],shape(LATTICE_FCCTOBCC_BAINROT)) if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' - if (present(a_fcc) .and. present(a_bcc)) then ! fcc -> bcc transformation - if ( a_fcc <= 0.0_pReal .or. a_bcc <= 0.0_pReal) print*, 'mist' + if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation + if (a_bcc <= 0.0_pReal) print*, 'mist' do i = 1_pInt,sum(Ntrans) - R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & ! Pitsch rotation + R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & lattice_fccTobcc_systemTrans(4,i)*INRAD) - B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & ! Rotation of fcc to Bain coordinate system + B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & lattice_fccTobcc_bainRot(4,i)*INRAD) x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) @@ -2736,7 +2574,7 @@ subroutine lattice_Trans(Q,S,Ntrans,cOverA,a_fcc,a_bcc) Q(1:3,1:3,i) = math_mul33x33(R,B) S(1:3,1:3,i) = math_mul33x33(R,U) - MATH_I3 enddo - elseif (present(cOverA)) then + elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation ss = MATH_I3 sd = MATH_I3 ss(1,3) = sqrt(2.0_pReal)/4.0_pReal @@ -2750,10 +2588,10 @@ subroutine lattice_Trans(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 + 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 enddo endif -end subroutine lattice_Trans +end subroutine buildTransformationSystem end module lattice diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index b6d9c65f4..0c56e6ba5 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -108,7 +108,7 @@ module plastic_dislotwin integer(pInt), dimension(:,:), allocatable :: & fcc_twinNucleationSlipPair ! ToDo: Better name? Is also use for trans real(pReal), dimension(:,:), allocatable :: & - forestProjectionEdge, & + forestProjection, & C66 real(pReal), dimension(:,:,:), allocatable :: & Schmid_trans, & @@ -305,7 +305,7 @@ subroutine plastic_dislotwin_init prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%forestProjectionEdge= lattice_forestProjection (prm%Nslip,structure(1:3),& + prm%forestProjection = lattice_forestProjection (prm%Nslip,structure(1:3),& config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & @@ -323,7 +323,7 @@ subroutine plastic_dislotwin_init prm%B = config%getFloats('b', requiredShape=shape(prm%Nslip), & defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) prm%tau_peierls = config%getFloats('tau_peierls',requiredShape=shape(prm%Nslip), & - defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) + defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) ! Deprecated prm%CEdgeDipMinDistance = config%getFloat('cedgedipmindistance') @@ -337,7 +337,7 @@ subroutine plastic_dislotwin_init prm%p = math_expand(prm%p, prm%Nslip) prm%q = math_expand(prm%q, prm%Nslip) prm%B = math_expand(prm%B, prm%Nslip) - prm%tau_peierls = math_expand(prm%tau_peierls, prm%Nslip) + prm%tau_peierls = math_expand(prm%tau_peierls, prm%Nslip) ! sanity checks if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//'rho0 ' @@ -422,6 +422,12 @@ subroutine plastic_dislotwin_init 0.0_pReal, & config%getFloat('a_bcc', defaultVal=0.0_pReal), & config%getFloat('a_fcc', defaultVal=0.0_pReal)) + + prm%Schmid_trans = lattice_SchmidMatrix_trans(prm%Ntrans, & + config%getString('trans_lattice_structure'), & + 0.0_pReal, & + config%getFloat('a_bcc', defaultVal=0.0_pReal), & + config%getFloat('a_fcc', defaultVal=0.0_pReal)) if (lattice_structure(p) /= LATTICE_fcc_ID) then prm%Ndot0_trans = config%getFloats('ndot0_trans') @@ -470,7 +476,7 @@ subroutine plastic_dislotwin_init prm%D0 = config%getFloat('d0') prm%Qsd = config%getFloat('qsd') - prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') + prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') ! Deprecated if (config%keyExists('dipoleformationfactor')) call IO_error(1,ext_msg='use /nodipoleformation/') prm%dipoleformation = .not. config%keyExists('/nodipoleformation/') prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal) @@ -615,19 +621,6 @@ subroutine plastic_dislotwin_init plasticState(p)%state (offset_slip+1:offset_slip+plasticState(p)%nslip,1:NipcMyPhase) -! DEPRECATED BEGIN - allocate(prm%Schmid_trans(3,3,prm%totalNtrans),source = 0.0_pReal) - i = 0_pInt - transFamiliesLoop: do f = 1_pInt,size(prm%Ntrans,1) - index_myFamily = sum(prm%Ntrans(1:f-1_pInt)) ! index in truncated trans system list - transSystemsLoop: do j = 1_pInt,prm%Ntrans(f) - i = i + 1_pInt - prm%Schmid_trans(1:3,1:3,i) = lattice_Strans(1:3,1:3,sum(lattice_Ntranssystem(1:f-1,p))+j,p) - enddo transSystemsLoop - enddo transFamiliesLoop -! DEPRECATED END - - startIndex=1_pInt endIndex=prm%totalNslip stt%rhoEdge=>plasticState(p)%state(startIndex:endIndex,:) @@ -793,7 +786,7 @@ subroutine plastic_dislotwin_microstructure(temperature,ipc,ip,el) forall (i = 1_pInt:prm%totalNslip) & mse%invLambdaSlip(i,of) = & sqrt(dot_product((stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of)),& - prm%forestProjectionEdge(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) + prm%forestProjection(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation !$OMP CRITICAL (evilmatmul) From 226bbad0135c1fd7fed892cd2e3b080321ab9beb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 08:31:13 +0100 Subject: [PATCH 149/372] don't waste character space --- src/plastic_phenopowerlaw.f90 | 65 ++++++++++++++++++----------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 347e2d8f8..9ba8dfc01 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -177,20 +177,21 @@ subroutine plastic_phenopowerlaw_init if (phase_plasticity(p) /= PLASTICITY_PHENOPOWERLAW_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & - stt => state(phase_plasticityInstance(p))) + stt => state(phase_plasticityInstance(p)), & + config => config_phase(p)) - structure = config_phase(p)%getString('lattice_structure') + structure = config%getString('lattice_structure') !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined - prm%twinB = config_phase(p)%getFloat('twin_b',defaultVal=1.0_pReal) - prm%twinC = config_phase(p)%getFloat('twin_c',defaultVal=0.0_pReal) - prm%twinD = config_phase(p)%getFloat('twin_d',defaultVal=0.0_pReal) - prm%twinE = config_phase(p)%getFloat('twin_e',defaultVal=0.0_pReal) + prm%twinB = config%getFloat('twin_b',defaultVal=1.0_pReal) + prm%twinC = config%getFloat('twin_c',defaultVal=0.0_pReal) + prm%twinD = config%getFloat('twin_d',defaultVal=0.0_pReal) + prm%twinE = config%getFloat('twin_e',defaultVal=0.0_pReal) - prm%aTolResistance = config_phase(p)%getFloat('atol_resistance',defaultVal=1.0_pReal) - prm%aTolShear = config_phase(p)%getFloat('atol_shear', defaultVal=1.0e-6_pReal) - prm%aTolTwinfrac = config_phase(p)%getFloat('atol_twinfrac', defaultVal=1.0e-6_pReal) + prm%aTolResistance = config%getFloat('atol_resistance',defaultVal=1.0_pReal) + prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + prm%aTolTwinfrac = config%getFloat('atol_twinfrac', defaultVal=1.0e-6_pReal) ! sanity checks if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//'aTolresistance ' @@ -199,13 +200,13 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! slip related parameters - prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then - prm%nonSchmidCoeff = config_phase(p)%getFloats('nonschmid_coefficients',& + 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) @@ -214,18 +215,18 @@ subroutine plastic_phenopowerlaw_init prm%nonSchmid_neg = prm%Schmid_slip endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - config_phase(p)%getFloats('interaction_slipslip'), & + config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%xi_slip_0 = config_phase(p)%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) - prm%xi_slip_sat = config_phase(p)%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) - prm%H_int = config_phase(p)%getFloats('h_int', requiredSize=size(prm%Nslip), & + 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))]) - prm%gdot0_slip = config_phase(p)%getFloat('gdot0_slip') - prm%n_slip = config_phase(p)%getFloat('n_slip') - prm%a_slip = config_phase(p)%getFloat('a_slip') - prm%h0_SlipSlip = config_phase(p)%getFloat('h0_slipslip') + prm%gdot0_slip = config%getFloat('gdot0_slip') + prm%n_slip = config%getFloat('n_slip') + prm%a_slip = config%getFloat('a_slip') + prm%h0_SlipSlip = config%getFloat('h0_slipslip') ! expand: family => system prm%xi_slip_0 = math_expand(prm%xi_slip_0, prm%Nslip) @@ -245,23 +246,23 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! twin related parameters - prm%Ntwin = config_phase(p)%getInts('ntwin', defaultVal=emptyIntArray) + prm%Ntwin = config%getInts('ntwin', defaultVal=emptyIntArray) prm%totalNtwin = sum(prm%Ntwin) twinActive: if (prm%totalNtwin > 0_pInt) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_TwinTwin = lattice_interaction_TwinTwin(prm%Ntwin,& - config_phase(p)%getFloats('interaction_twintwin'), & + config%getFloats('interaction_twintwin'), & structure(1:3)) prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,structure(1:3),& - config_phase(p)%getFloat('c/a')) + config%getFloat('c/a')) - prm%xi_twin_0 = config_phase(p)%getFloats('tau0_twin',requiredSize=size(prm%Ntwin)) + prm%xi_twin_0 = config%getFloats('tau0_twin',requiredSize=size(prm%Ntwin)) - prm%gdot0_twin = config_phase(p)%getFloat('gdot0_twin') - prm%n_twin = config_phase(p)%getFloat('n_twin') - prm%spr = config_phase(p)%getFloat('s_pr') - prm%h0_TwinTwin = config_phase(p)%getFloat('h0_twintwin') + prm%gdot0_twin = config%getFloat('gdot0_twin') + prm%n_twin = config%getFloat('n_twin') + prm%spr = config%getFloat('s_pr') + prm%h0_TwinTwin = config%getFloat('h0_twintwin') ! expand: family => system prm%xi_twin_0 = math_expand(prm%xi_twin_0, prm%Ntwin) @@ -279,10 +280,10 @@ 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_SlipTwin(prm%Nslip,prm%Ntwin,& - config_phase(p)%getFloats('interaction_sliptwin'), & + config%getFloats('interaction_sliptwin'), & structure(1:3)) prm%interaction_TwinSlip = lattice_interaction_TwinSlip(prm%Ntwin,prm%Nslip,& - config_phase(p)%getFloats('interaction_twinslip'), & + config%getFloats('interaction_twinslip'), & structure(1:3)) else slipAndTwinActive allocate(prm%interaction_SlipTwin(prm%totalNslip,prm%TotalNtwin)) ! at least one dimension is 0 @@ -297,7 +298,7 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! output pararameters - outputs = config_phase(p)%getStrings('(output)',defaultVal=emptyStringArray) + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID From 708fc9f6b339b80c6c07571d0afdd28b65ae2eeb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 08:32:47 +0100 Subject: [PATCH 150/372] not compatible with generalized solution handling --- src/homogenization.f90 | 176 ++--------------------------------------- 1 file changed, 5 insertions(+), 171 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 82a97dc53..eb002dd60 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -26,9 +26,7 @@ module homogenization homogenization_maxSizePostResults, & thermal_maxSizePostResults, & damage_maxSizePostResults, & - vacancyflux_maxSizePostResults, & - porosity_maxSizePostResults, & - hydrogenflux_maxSizePostResults + porosity_maxSizePostResults real(pReal), dimension(:,:,:,:), allocatable, private :: & materialpoint_subF0, & !< def grad of IP at beginning of homogenization increment @@ -100,13 +98,8 @@ subroutine homogenization_init use damage_none use damage_local use damage_nonlocal - use vacancyflux_isoconc - use vacancyflux_isochempot - use vacancyflux_cahnhilliard use porosity_none use porosity_phasefield - use hydrogenflux_isoconc - use hydrogenflux_cahnhilliard use IO use numerics, only: & worldrank @@ -155,16 +148,6 @@ subroutine homogenization_init if (any(damage_type == DAMAGE_nonlocal_ID)) & call damage_nonlocal_init(FILEUNIT) -!-------------------------------------------------------------------------------------------------- -! parse vacancy transport from config file - call IO_checkAndRewind(FILEUNIT) - if (any(vacancyflux_type == VACANCYFLUX_isoconc_ID)) & - call vacancyflux_isoconc_init() - if (any(vacancyflux_type == VACANCYFLUX_isochempot_ID)) & - call vacancyflux_isochempot_init(FILEUNIT) - if (any(vacancyflux_type == VACANCYFLUX_cahnhilliard_ID)) & - call vacancyflux_cahnhilliard_init(FILEUNIT) - !-------------------------------------------------------------------------------------------------- ! parse porosity from config file call IO_checkAndRewind(FILEUNIT) @@ -173,15 +156,6 @@ subroutine homogenization_init if (any(porosity_type == POROSITY_phasefield_ID)) & call porosity_phasefield_init(FILEUNIT) -!-------------------------------------------------------------------------------------------------- -! parse hydrogen transport from config file - call IO_checkAndRewind(FILEUNIT) - if (any(hydrogenflux_type == HYDROGENFLUX_isoconc_ID)) & - call hydrogenflux_isoconc_init() - if (any(hydrogenflux_type == HYDROGENFLUX_cahnhilliard_ID)) & - call hydrogenflux_cahnhilliard_init(FILEUNIT) - close(FILEUNIT) - !-------------------------------------------------------------------------------------------------- ! write description file for homogenization output mainProcess2: if (worldrank == 0) then @@ -277,35 +251,6 @@ subroutine homogenization_init enddo endif endif - i = vacancyflux_typeInstance(p) ! which instance of this vacancy flux type - valid = .true. ! assume valid - select case(vacancyflux_type(p)) ! split per vacancy flux type - case (VACANCYFLUX_isoconc_ID) - outputName = VACANCYFLUX_isoconc_label - thisNoutput => null() - thisOutput => null() - thisSize => null() - case (VACANCYFLUX_isochempot_ID) - outputName = VACANCYFLUX_isochempot_label - thisNoutput => vacancyflux_isochempot_Noutput - thisOutput => vacancyflux_isochempot_output - thisSize => vacancyflux_isochempot_sizePostResult - case (VACANCYFLUX_cahnhilliard_ID) - outputName = VACANCYFLUX_cahnhilliard_label - thisNoutput => vacancyflux_cahnhilliard_Noutput - thisOutput => vacancyflux_cahnhilliard_output - thisSize => vacancyflux_cahnhilliard_sizePostResult - case default - valid = .false. - end select - if (valid) then - write(FILEUNIT,'(a)') '(vacancyflux)'//char(9)//trim(outputName) - if (vacancyflux_type(p) /= VACANCYFLUX_isoconc_ID) then - do e = 1,thisNoutput(i) - write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) - enddo - endif - endif i = porosity_typeInstance(p) ! which instance of this porosity type valid = .true. ! assume valid select case(porosity_type(p)) ! split per porosity type @@ -330,30 +275,6 @@ subroutine homogenization_init enddo endif endif - i = hydrogenflux_typeInstance(p) ! which instance of this hydrogen flux type - valid = .true. ! assume valid - select case(hydrogenflux_type(p)) ! split per hydrogen flux type - case (HYDROGENFLUX_isoconc_ID) - outputName = HYDROGENFLUX_isoconc_label - thisNoutput => null() - thisOutput => null() - thisSize => null() - case (HYDROGENFLUX_cahnhilliard_ID) - outputName = HYDROGENFLUX_cahnhilliard_label - thisNoutput => hydrogenflux_cahnhilliard_Noutput - thisOutput => hydrogenflux_cahnhilliard_output - thisSize => hydrogenflux_cahnhilliard_sizePostResult - case default - valid = .false. - end select - if (valid) then - write(FILEUNIT,'(a)') '(hydrogenflux)'//char(9)//trim(outputName) - if (hydrogenflux_type(p) /= HYDROGENFLUX_isoconc_ID) then - do e = 1,thisNoutput(i) - write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) - enddo - endif - endif endif enddo close(FILEUNIT) @@ -383,25 +304,19 @@ subroutine homogenization_init homogenization_maxSizePostResults = 0_pInt thermal_maxSizePostResults = 0_pInt damage_maxSizePostResults = 0_pInt - vacancyflux_maxSizePostResults = 0_pInt porosity_maxSizePostResults = 0_pInt - hydrogenflux_maxSizePostResults = 0_pInt do p = 1,size(config_homogenization) homogenization_maxSizePostResults = max(homogenization_maxSizePostResults,homogState (p)%sizePostResults) thermal_maxSizePostResults = max(thermal_maxSizePostResults, thermalState (p)%sizePostResults) damage_maxSizePostResults = max(damage_maxSizePostResults ,damageState (p)%sizePostResults) - vacancyflux_maxSizePostResults = max(vacancyflux_maxSizePostResults ,vacancyfluxState (p)%sizePostResults) porosity_maxSizePostResults = max(porosity_maxSizePostResults ,porosityState (p)%sizePostResults) - hydrogenflux_maxSizePostResults = max(hydrogenflux_maxSizePostResults ,hydrogenfluxState(p)%sizePostResults) enddo materialpoint_sizeResults = 1 & ! grain count + 1 + homogenization_maxSizePostResults & ! homogSize & homogResult + thermal_maxSizePostResults & + damage_maxSizePostResults & - + vacancyflux_maxSizePostResults & + porosity_maxSizePostResults & - + hydrogenflux_maxSizePostResults & + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + constitutive_source_maxSizePostResults) @@ -460,9 +375,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) homogState, & thermalState, & damageState, & - vacancyfluxState, & porosityState, & - hydrogenfluxState, & phase_Nsources, & mappingHomogenization, & phaseAt, phasememberAt, & @@ -569,18 +482,10 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - vacancyfluxState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal vacancy transport state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & porosityState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal porosity state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - hydrogenfluxState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal hydrogen transport state enddo NiterationHomog = 0_pInt @@ -654,18 +559,10 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - vacancyfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal vacancy transport state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal porosity state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - hydrogenfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal hydrogen transport state materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad endif steppingNeeded @@ -729,18 +626,10 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - vacancyfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & - vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal vacancy transport state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal porosity state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - hydrogenfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & - hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal hydrogen transport state endif endif converged @@ -846,9 +735,7 @@ subroutine materialpoint_postResults homogState, & thermalState, & damageState, & - vacancyfluxState, & porosityState, & - hydrogenfluxState, & plasticState, & sourceState, & material_phase, & @@ -878,9 +765,7 @@ subroutine materialpoint_postResults theSize = homogState (mappingHomogenization(2,i,e))%sizePostResults & + thermalState (mappingHomogenization(2,i,e))%sizePostResults & + damageState (mappingHomogenization(2,i,e))%sizePostResults & - + vacancyfluxState (mappingHomogenization(2,i,e))%sizePostResults & - + porosityState (mappingHomogenization(2,i,e))%sizePostResults & - + hydrogenfluxState(mappingHomogenization(2,i,e))%sizePostResults + + porosityState (mappingHomogenization(2,i,e))%sizePostResults materialpoint_results(thePos+1,i,e) = real(theSize,pReal) ! tell size of homogenization results thePos = thePos + 1_pInt @@ -964,12 +849,10 @@ function homogenization_updateState(ip,el) homogenization_type, & thermal_type, & damage_type, & - vacancyflux_type, & homogenization_maxNgrains, & HOMOGENIZATION_RGC_ID, & THERMAL_adiabatic_ID, & - DAMAGE_local_ID, & - VACANCYFLUX_isochempot_ID + DAMAGE_local_ID use crystallite, only: & crystallite_P, & crystallite_dPdF, & @@ -981,8 +864,6 @@ function homogenization_updateState(ip,el) thermal_adiabatic_updateState use damage_local, only: & damage_local_updateState - use vacancyflux_isochempot, only: & - vacancyflux_isochempot_updateState implicit none integer(pInt), intent(in) :: & @@ -1023,15 +904,6 @@ function homogenization_updateState(ip,el) el) end select chosenDamage - chosenVacancyflux: select case (vacancyflux_type(mesh_element(3,el))) - case (VACANCYFLUX_isochempot_ID) chosenVacancyflux - homogenization_updateState = & - homogenization_updateState .and. & - vacancyflux_isochempot_updateState(materialpoint_subdt(ip,el), & - ip, & - el) - end select chosenVacancyflux - end function homogenization_updateState @@ -1095,15 +967,11 @@ function homogenization_postResults(ip,el) homogState, & thermalState, & damageState, & - vacancyfluxState, & porosityState, & - hydrogenfluxState, & homogenization_type, & thermal_type, & damage_type, & - vacancyflux_type, & porosity_type, & - hydrogenflux_type, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & HOMOGENIZATION_RGC_ID, & @@ -1113,13 +981,8 @@ function homogenization_postResults(ip,el) DAMAGE_none_ID, & DAMAGE_local_ID, & DAMAGE_nonlocal_ID, & - VACANCYFLUX_isoconc_ID, & - VACANCYFLUX_isochempot_ID, & - VACANCYFLUX_cahnhilliard_ID, & POROSITY_none_ID, & - POROSITY_phasefield_ID, & - HYDROGENFLUX_isoconc_ID, & - HYDROGENFLUX_cahnhilliard_ID + POROSITY_phasefield_ID use homogenization_isostrain, only: & homogenization_isostrain_postResults use homogenization_RGC, only: & @@ -1132,14 +995,8 @@ function homogenization_postResults(ip,el) damage_local_postResults use damage_nonlocal, only: & damage_nonlocal_postResults - use vacancyflux_isochempot, only: & - vacancyflux_isochempot_postResults - use vacancyflux_cahnhilliard, only: & - vacancyflux_cahnhilliard_postResults use porosity_phasefield, only: & porosity_phasefield_postResults - use hydrogenflux_cahnhilliard, only: & - hydrogenflux_cahnhilliard_postResults implicit none integer(pInt), intent(in) :: & @@ -1148,9 +1005,7 @@ function homogenization_postResults(ip,el) real(pReal), dimension( homogState (mappingHomogenization(2,ip,el))%sizePostResults & + thermalState (mappingHomogenization(2,ip,el))%sizePostResults & + damageState (mappingHomogenization(2,ip,el))%sizePostResults & - + vacancyfluxState (mappingHomogenization(2,ip,el))%sizePostResults & - + porosityState (mappingHomogenization(2,ip,el))%sizePostResults & - + hydrogenfluxState(mappingHomogenization(2,ip,el))%sizePostResults) :: & + + porosityState (mappingHomogenization(2,ip,el))%sizePostResults) :: & homogenization_postResults integer(pInt) :: & startPos, endPos @@ -1205,18 +1060,6 @@ function homogenization_postResults(ip,el) damage_nonlocal_postResults(ip, el) end select chosenDamage - startPos = endPos + 1_pInt - endPos = endPos + vacancyfluxState(mappingHomogenization(2,ip,el))%sizePostResults - chosenVacancyflux: select case (vacancyflux_type(mesh_element(3,el))) - case (VACANCYFLUX_isoconc_ID) chosenVacancyflux - - case (VACANCYFLUX_isochempot_ID) chosenVacancyflux - homogenization_postResults(startPos:endPos) = & - vacancyflux_isochempot_postResults(ip, el) - case (VACANCYFLUX_cahnhilliard_ID) chosenVacancyflux - homogenization_postResults(startPos:endPos) = & - vacancyflux_cahnhilliard_postResults(ip, el) - end select chosenVacancyflux startPos = endPos + 1_pInt endPos = endPos + porosityState(mappingHomogenization(2,ip,el))%sizePostResults @@ -1228,15 +1071,6 @@ function homogenization_postResults(ip,el) porosity_phasefield_postResults(ip, el) end select chosenPorosity - startPos = endPos + 1_pInt - endPos = endPos + hydrogenfluxState(mappingHomogenization(2,ip,el))%sizePostResults - chosenHydrogenflux: select case (hydrogenflux_type(mesh_element(3,el))) - case (HYDROGENFLUX_isoconc_ID) chosenHydrogenflux - - case (HYDROGENFLUX_cahnhilliard_ID) chosenHydrogenflux - homogenization_postResults(startPos:endPos) = & - hydrogenflux_cahnhilliard_postResults(ip, el) - end select chosenHydrogenflux end function homogenization_postResults From 1520adb3fb21d86675703db47af610bf98a38006 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 08:37:58 +0100 Subject: [PATCH 151/372] not compatible with generalized solute flux --- src/constitutive.f90 | 73 ++------------------------------------------ 1 file changed, 3 insertions(+), 70 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 8294047e7..040f3c39e 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -88,14 +88,9 @@ subroutine constitutive_init() SOURCE_damage_isoDuctile_ID, & SOURCE_damage_anisoBrittle_ID, & SOURCE_damage_anisoDuctile_ID, & - SOURCE_vacancy_phenoplasticity_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID, & KINEMATICS_cleavage_opening_ID, & KINEMATICS_slipplane_opening_ID, & KINEMATICS_thermal_expansion_ID, & - KINEMATICS_vacancy_strain_ID, & - KINEMATICS_hydrogen_strain_ID, & ELASTICITY_HOOKE_label, & PLASTICITY_NONE_label, & PLASTICITY_ISOTROPIC_label, & @@ -110,9 +105,6 @@ subroutine constitutive_init() SOURCE_damage_isoDuctile_label, & SOURCE_damage_anisoBrittle_label, & SOURCE_damage_anisoDuctile_label, & - SOURCE_vacancy_phenoplasticity_label, & - SOURCE_vacancy_irradiation_label, & - SOURCE_vacancy_thermalfluc_label, & plasticState, & sourceState @@ -129,14 +121,9 @@ subroutine constitutive_init() use source_damage_isoDuctile use source_damage_anisoBrittle use source_damage_anisoDuctile - use source_vacancy_phenoplasticity - use source_vacancy_irradiation - use source_vacancy_thermalfluc use kinematics_cleavage_opening use kinematics_slipplane_opening use kinematics_thermal_expansion - use kinematics_vacancy_strain - use kinematics_hydrogen_strain implicit none integer(pInt), parameter :: FILEUNIT = 204_pInt @@ -179,9 +166,6 @@ subroutine constitutive_init() if (any(phase_source == SOURCE_damage_isoDuctile_ID)) call source_damage_isoDuctile_init(FILEUNIT) if (any(phase_source == SOURCE_damage_anisoBrittle_ID)) call source_damage_anisoBrittle_init(FILEUNIT) if (any(phase_source == SOURCE_damage_anisoDuctile_ID)) call source_damage_anisoDuctile_init(FILEUNIT) - if (any(phase_source == SOURCE_vacancy_phenoplasticity_ID)) call source_vacancy_phenoplasticity_init(FILEUNIT) - if (any(phase_source == SOURCE_vacancy_irradiation_ID)) call source_vacancy_irradiation_init(FILEUNIT) - if (any(phase_source == SOURCE_vacancy_thermalfluc_ID)) call source_vacancy_thermalfluc_init(FILEUNIT) !-------------------------------------------------------------------------------------------------- ! parse kinematic mechanisms from config file @@ -189,8 +173,6 @@ subroutine constitutive_init() if (any(phase_kinematics == KINEMATICS_cleavage_opening_ID)) call kinematics_cleavage_opening_init(FILEUNIT) if (any(phase_kinematics == KINEMATICS_slipplane_opening_ID)) call kinematics_slipplane_opening_init(FILEUNIT) if (any(phase_kinematics == KINEMATICS_thermal_expansion_ID)) call kinematics_thermal_expansion_init(FILEUNIT) - if (any(phase_kinematics == KINEMATICS_vacancy_strain_ID)) call kinematics_vacancy_strain_init(FILEUNIT) - if (any(phase_kinematics == KINEMATICS_hydrogen_strain_ID)) call kinematics_hydrogen_strain_init(FILEUNIT) close(FILEUNIT) call config_deallocate('material.config/phase') @@ -283,21 +265,6 @@ subroutine constitutive_init() outputName = SOURCE_damage_anisoDuctile_label thisOutput => source_damage_anisoDuctile_output thisSize => source_damage_anisoDuctile_sizePostResult - case (SOURCE_vacancy_phenoplasticity_ID) sourceType - ins = source_vacancy_phenoplasticity_instance(ph) - outputName = SOURCE_vacancy_phenoplasticity_label - thisOutput => source_vacancy_phenoplasticity_output - thisSize => source_vacancy_phenoplasticity_sizePostResult - case (SOURCE_vacancy_irradiation_ID) sourceType - ins = source_vacancy_irradiation_instance(ph) - outputName = SOURCE_vacancy_irradiation_label - thisOutput => source_vacancy_irradiation_output - thisSize => source_vacancy_irradiation_sizePostResult - case (SOURCE_vacancy_thermalfluc_ID) sourceType - ins = source_vacancy_thermalfluc_instance(ph) - outputName = SOURCE_vacancy_thermalfluc_label - thisOutput => source_vacancy_thermalfluc_output - thisSize => source_vacancy_thermalfluc_sizePostResult case default sourceType knownSource = .false. end select sourceType @@ -577,9 +544,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e PLASTICITY_isotropic_ID, & KINEMATICS_cleavage_opening_ID, & KINEMATICS_slipplane_opening_ID, & - KINEMATICS_thermal_expansion_ID, & - KINEMATICS_vacancy_strain_ID, & - KINEMATICS_hydrogen_strain_ID + KINEMATICS_thermal_expansion_ID use plastic_isotropic, only: & plastic_isotropic_LiAndItsTangent use kinematics_cleavage_opening, only: & @@ -588,10 +553,6 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e kinematics_slipplane_opening_LiAndItsTangent use kinematics_thermal_expansion, only: & kinematics_thermal_expansion_LiAndItsTangent - use kinematics_vacancy_strain, only: & - kinematics_vacancy_strain_LiAndItsTangent - use kinematics_hydrogen_strain, only: & - kinematics_hydrogen_strain_LiAndItsTangent implicit none integer(pInt), intent(in) :: & @@ -644,10 +605,6 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e call kinematics_slipplane_opening_LiAndItsTangent(my_Li, my_dLi_dS, S6, ipc, ip, el) case (KINEMATICS_thermal_expansion_ID) kinematicsType call kinematics_thermal_expansion_LiAndItsTangent(my_Li, my_dLi_dS, ipc, ip, el) - case (KINEMATICS_vacancy_strain_ID) kinematicsType - call kinematics_vacancy_strain_LiAndItsTangent(my_Li, my_dLi_dS, ipc, ip, el) - case (KINEMATICS_hydrogen_strain_ID) kinematicsType - call kinematics_hydrogen_strain_LiAndItsTangent(my_Li, my_dLi_dS, ipc, ip, el) case default kinematicsType my_Li = 0.0_pReal my_dLi_dS = 0.0_pReal @@ -684,15 +641,9 @@ pure function constitutive_initialFi(ipc, ip, el) phase_kinematics, & phase_Nkinematics, & material_phase, & - KINEMATICS_thermal_expansion_ID, & - KINEMATICS_vacancy_strain_ID, & - KINEMATICS_hydrogen_strain_ID + KINEMATICS_thermal_expansion_ID use kinematics_thermal_expansion, only: & kinematics_thermal_expansion_initialStrain - use kinematics_vacancy_strain, only: & - kinematics_vacancy_strain_initialStrain - use kinematics_hydrogen_strain, only: & - kinematics_hydrogen_strain_initialStrain implicit none integer(pInt), intent(in) :: & @@ -711,12 +662,6 @@ pure function constitutive_initialFi(ipc, ip, el) case (KINEMATICS_thermal_expansion_ID) kinematicsType constitutive_initialFi = & constitutive_initialFi + kinematics_thermal_expansion_initialStrain(ipc, ip, el) - case (KINEMATICS_vacancy_strain_ID) kinematicsType - constitutive_initialFi = & - constitutive_initialFi + kinematics_vacancy_strain_initialStrain(ipc, ip, el) - case (KINEMATICS_hydrogen_strain_ID) kinematicsType - constitutive_initialFi = & - constitutive_initialFi + kinematics_hydrogen_strain_initialStrain(ipc, ip, el) end select kinematicsType enddo KinematicsLoop @@ -986,19 +931,13 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) material_phase, & PLASTICITY_KINEHARDENING_ID, & PLASTICITY_NONLOCAL_ID, & - SOURCE_damage_isoBrittle_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID + SOURCE_damage_isoBrittle_ID use plastic_kinehardening, only: & plastic_kinehardening_deltaState use plastic_nonlocal, only: & plastic_nonlocal_deltaState use source_damage_isoBrittle, only: & source_damage_isoBrittle_deltaState - use source_vacancy_irradiation, only: & - source_vacancy_irradiation_deltaState - use source_vacancy_thermalfluc, only: & - source_vacancy_thermalfluc_deltaState implicit none integer(pInt), intent(in) :: & @@ -1035,12 +974,6 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) call source_damage_isoBrittle_deltaState (constitutive_homogenizedC(ipc,ip,el), Fe, & ipc, ip, el) - case (SOURCE_vacancy_irradiation_ID) sourceType - call source_vacancy_irradiation_deltaState(ipc, ip, el) - - case (SOURCE_vacancy_thermalfluc_ID) sourceType - call source_vacancy_thermalfluc_deltaState(ipc, ip, el) - end select sourceType enddo SourceLoop From 13f321d992b0f0f4693a1f9c97be8a154561cd96 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 09:00:57 +0100 Subject: [PATCH 152/372] cleaning almost done --- src/CMakeLists.txt | 30 +------- src/CPFEM.f90 | 4 - src/CPFEM2.f90 | 4 - src/commercialFEM_fileList.f90 | 12 --- src/homogenization.f90 | 80 +------------------- src/material.f90 | 124 ++----------------------------- src/source_damage_isoBrittle.f90 | 10 +-- 7 files changed, 15 insertions(+), 249 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2e4462243..a84609087 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -90,9 +90,7 @@ list(APPEND OBJECTFILES $) add_library (KINEMATICS OBJECT "kinematics_cleavage_opening.f90" "kinematics_slipplane_opening.f90" - "kinematics_thermal_expansion.f90" - "kinematics_vacancy_strain.f90" - "kinematics_hydrogen_strain.f90") + "kinematics_thermal_expansion.f90") add_dependencies(KINEMATICS DAMASK_HELPERS) list(APPEND OBJECTFILES $) @@ -102,10 +100,7 @@ add_library (SOURCE OBJECT "source_damage_isoBrittle.f90" "source_damage_isoDuctile.f90" "source_damage_anisoBrittle.f90" - "source_damage_anisoDuctile.f90" - "source_vacancy_phenoplasticity.f90" - "source_vacancy_irradiation.f90" - "source_vacancy_thermalfluc.f90") + "source_damage_anisoDuctile.f90") add_dependencies(SOURCE DAMASK_HELPERS) list(APPEND OBJECTFILES $) @@ -124,25 +119,6 @@ add_library(HOMOGENIZATION OBJECT add_dependencies(HOMOGENIZATION CRYSTALLITE) list(APPEND OBJECTFILES $) -add_library(HYDROGENFLUX OBJECT - "hydrogenflux_isoconc.f90" - "hydrogenflux_cahnhilliard.f90") -add_dependencies(HYDROGENFLUX CRYSTALLITE) -list(APPEND OBJECTFILES $) - -add_library(POROSITY OBJECT - "porosity_none.f90" - "porosity_phasefield.f90") -add_dependencies(POROSITY CRYSTALLITE) -list(APPEND OBJECTFILES $) - -add_library(VACANCYFLUX OBJECT - "vacancyflux_isoconc.f90" - "vacancyflux_isochempot.f90" - "vacancyflux_cahnhilliard.f90") -add_dependencies(VACANCYFLUX CRYSTALLITE) -list(APPEND OBJECTFILES $) - add_library(DAMAGE OBJECT "damage_none.f90" "damage_local.f90" @@ -158,7 +134,7 @@ add_dependencies(THERMAL CRYSTALLITE) list(APPEND OBJECTFILES $) add_library(DAMASK_ENGINE OBJECT "homogenization.f90") -add_dependencies(DAMASK_ENGINE THERMAL DAMAGE VACANCYFLUX POROSITY HYDROGENFLUX HOMOGENIZATION) +add_dependencies(DAMASK_ENGINE THERMAL DAMAGE HOMOGENIZATION) list(APPEND OBJECTFILES $) add_library(DAMASK_CPFE OBJECT "CPFEM2.f90") diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 674a557b5..847688d57 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -304,8 +304,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt homogState, & thermalState, & damageState, & - vacancyfluxState, & - hydrogenfluxState, & phaseAt, phasememberAt, & material_phase, & phase_plasticity, & @@ -421,8 +419,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt homogState (homog)%state0 = homogState (homog)%state thermalState (homog)%state0 = thermalState (homog)%state damageState (homog)%state0 = damageState (homog)%state - vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state - hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state enddo diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 2aed858a7..29e1ac744 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -203,8 +203,6 @@ subroutine CPFEM_age() homogState, & thermalState, & damageState, & - vacancyfluxState, & - hydrogenfluxState, & material_phase, & phase_plasticity, & phase_Nsources @@ -268,8 +266,6 @@ if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & homogState (homog)%state0 = homogState (homog)%state thermalState (homog)%state0 = thermalState (homog)%state damageState (homog)%state0 = damageState (homog)%state - vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state - hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state enddo if (restartWrite) then diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 36f0244ef..8d3e9c816 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -21,14 +21,9 @@ #include "source_damage_isoDuctile.f90" #include "source_damage_anisoBrittle.f90" #include "source_damage_anisoDuctile.f90" -#include "source_vacancy_phenoplasticity.f90" -#include "source_vacancy_irradiation.f90" -#include "source_vacancy_thermalfluc.f90" #include "kinematics_cleavage_opening.f90" #include "kinematics_slipplane_opening.f90" #include "kinematics_thermal_expansion.f90" -#include "kinematics_vacancy_strain.f90" -#include "kinematics_hydrogen_strain.f90" #include "plastic_none.f90" #include "plastic_isotropic.f90" #include "plastic_phenopowerlaw.f90" @@ -47,12 +42,5 @@ #include "damage_none.f90" #include "damage_local.f90" #include "damage_nonlocal.f90" -#include "vacancyflux_isoconc.f90" -#include "vacancyflux_isochempot.f90" -#include "vacancyflux_cahnhilliard.f90" -#include "porosity_none.f90" -#include "porosity_phasefield.f90" -#include "hydrogenflux_isoconc.f90" -#include "hydrogenflux_cahnhilliard.f90" #include "homogenization.f90" #include "CPFEM.f90" diff --git a/src/homogenization.f90 b/src/homogenization.f90 index eb002dd60..4663caa9d 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -25,8 +25,7 @@ module homogenization materialpoint_sizeResults, & homogenization_maxSizePostResults, & thermal_maxSizePostResults, & - damage_maxSizePostResults, & - porosity_maxSizePostResults + damage_maxSizePostResults real(pReal), dimension(:,:,:,:), allocatable, private :: & materialpoint_subF0, & !< def grad of IP at beginning of homogenization increment @@ -98,8 +97,6 @@ subroutine homogenization_init use damage_none use damage_local use damage_nonlocal - use porosity_none - use porosity_phasefield use IO use numerics, only: & worldrank @@ -148,14 +145,6 @@ subroutine homogenization_init if (any(damage_type == DAMAGE_nonlocal_ID)) & call damage_nonlocal_init(FILEUNIT) -!-------------------------------------------------------------------------------------------------- -! parse porosity from config file - call IO_checkAndRewind(FILEUNIT) - if (any(porosity_type == POROSITY_none_ID)) & - call porosity_none_init() - if (any(porosity_type == POROSITY_phasefield_ID)) & - call porosity_phasefield_init(FILEUNIT) - !-------------------------------------------------------------------------------------------------- ! write description file for homogenization output mainProcess2: if (worldrank == 0) then @@ -251,30 +240,6 @@ subroutine homogenization_init enddo endif endif - i = porosity_typeInstance(p) ! which instance of this porosity type - valid = .true. ! assume valid - select case(porosity_type(p)) ! split per porosity type - case (POROSITY_none_ID) - outputName = POROSITY_none_label - thisNoutput => null() - thisOutput => null() - thisSize => null() - case (POROSITY_phasefield_ID) - outputName = POROSITY_phasefield_label - thisNoutput => porosity_phasefield_Noutput - thisOutput => porosity_phasefield_output - thisSize => porosity_phasefield_sizePostResult - case default - valid = .false. - end select - if (valid) then - write(FILEUNIT,'(a)') '(porosity)'//char(9)//trim(outputName) - if (porosity_type(p) /= POROSITY_none_ID) then - do e = 1,thisNoutput(i) - write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) - enddo - endif - endif endif enddo close(FILEUNIT) @@ -304,19 +269,16 @@ subroutine homogenization_init homogenization_maxSizePostResults = 0_pInt thermal_maxSizePostResults = 0_pInt damage_maxSizePostResults = 0_pInt - porosity_maxSizePostResults = 0_pInt do p = 1,size(config_homogenization) homogenization_maxSizePostResults = max(homogenization_maxSizePostResults,homogState (p)%sizePostResults) thermal_maxSizePostResults = max(thermal_maxSizePostResults, thermalState (p)%sizePostResults) damage_maxSizePostResults = max(damage_maxSizePostResults ,damageState (p)%sizePostResults) - porosity_maxSizePostResults = max(porosity_maxSizePostResults ,porosityState (p)%sizePostResults) enddo materialpoint_sizeResults = 1 & ! grain count + 1 + homogenization_maxSizePostResults & ! homogSize & homogResult + thermal_maxSizePostResults & + damage_maxSizePostResults & - + porosity_maxSizePostResults & + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + constitutive_source_maxSizePostResults) @@ -375,7 +337,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) homogState, & thermalState, & damageState, & - porosityState, & phase_Nsources, & mappingHomogenization, & phaseAt, phasememberAt, & @@ -482,10 +443,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - porosityState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal porosity state enddo NiterationHomog = 0_pInt @@ -559,10 +516,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & - porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal porosity state materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad endif steppingNeeded @@ -626,10 +579,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal damage state - forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & - porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & - porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal porosity state endif endif converged @@ -735,7 +684,6 @@ subroutine materialpoint_postResults homogState, & thermalState, & damageState, & - porosityState, & plasticState, & sourceState, & material_phase, & @@ -764,8 +712,7 @@ subroutine materialpoint_postResults theSize = homogState (mappingHomogenization(2,i,e))%sizePostResults & + thermalState (mappingHomogenization(2,i,e))%sizePostResults & - + damageState (mappingHomogenization(2,i,e))%sizePostResults & - + porosityState (mappingHomogenization(2,i,e))%sizePostResults + + damageState (mappingHomogenization(2,i,e))%sizePostResults materialpoint_results(thePos+1,i,e) = real(theSize,pReal) ! tell size of homogenization results thePos = thePos + 1_pInt @@ -967,11 +914,9 @@ function homogenization_postResults(ip,el) homogState, & thermalState, & damageState, & - porosityState, & homogenization_type, & thermal_type, & damage_type, & - porosity_type, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & HOMOGENIZATION_RGC_ID, & @@ -980,9 +925,7 @@ function homogenization_postResults(ip,el) THERMAL_conduction_ID, & DAMAGE_none_ID, & DAMAGE_local_ID, & - DAMAGE_nonlocal_ID, & - POROSITY_none_ID, & - POROSITY_phasefield_ID + DAMAGE_nonlocal_ID use homogenization_isostrain, only: & homogenization_isostrain_postResults use homogenization_RGC, only: & @@ -995,8 +938,6 @@ function homogenization_postResults(ip,el) damage_local_postResults use damage_nonlocal, only: & damage_nonlocal_postResults - use porosity_phasefield, only: & - porosity_phasefield_postResults implicit none integer(pInt), intent(in) :: & @@ -1004,8 +945,7 @@ function homogenization_postResults(ip,el) el !< element number real(pReal), dimension( homogState (mappingHomogenization(2,ip,el))%sizePostResults & + thermalState (mappingHomogenization(2,ip,el))%sizePostResults & - + damageState (mappingHomogenization(2,ip,el))%sizePostResults & - + porosityState (mappingHomogenization(2,ip,el))%sizePostResults) :: & + + damageState (mappingHomogenization(2,ip,el))%sizePostResults) :: & homogenization_postResults integer(pInt) :: & startPos, endPos @@ -1060,18 +1000,6 @@ function homogenization_postResults(ip,el) damage_nonlocal_postResults(ip, el) end select chosenDamage - - startPos = endPos + 1_pInt - endPos = endPos + porosityState(mappingHomogenization(2,ip,el))%sizePostResults - chosenPorosity: select case (porosity_type(mesh_element(3,el))) - case (POROSITY_none_ID) chosenPorosity - - case (POROSITY_phasefield_ID) chosenPorosity - homogenization_postResults(startPos:endPos) = & - porosity_phasefield_postResults(ip, el) - end select chosenPorosity - - end function homogenization_postResults end module homogenization diff --git a/src/material.f90 b/src/material.f90 index c9dd28079..e52312c51 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -36,14 +36,9 @@ module material SOURCE_damage_isoDuctile_label = 'damage_isoductile', & SOURCE_damage_anisoBrittle_label = 'damage_anisobrittle', & SOURCE_damage_anisoDuctile_label = 'damage_anisoductile', & - SOURCE_vacancy_phenoplasticity_label = 'vacancy_phenoplasticity', & - SOURCE_vacancy_irradiation_label = 'vacancy_irradiation', & - SOURCE_vacancy_thermalfluc_label = 'vacancy_thermalfluctuation', & KINEMATICS_thermal_expansion_label = 'thermal_expansion', & KINEMATICS_cleavage_opening_label = 'cleavage_opening', & KINEMATICS_slipplane_opening_label = 'slipplane_opening', & - KINEMATICS_vacancy_strain_label = 'vacancy_strain', & - KINEMATICS_hydrogen_strain_label = 'hydrogen_strain', & STIFFNESS_DEGRADATION_damage_label = 'damage', & STIFFNESS_DEGRADATION_porosity_label = 'porosity', & THERMAL_isothermal_label = 'isothermal', & @@ -52,13 +47,8 @@ module material DAMAGE_none_label = 'none', & DAMAGE_local_label = 'local', & DAMAGE_nonlocal_label = 'nonlocal', & - VACANCYFLUX_isoconc_label = 'isoconcentration', & - VACANCYFLUX_isochempot_label = 'isochemicalpotential', & - VACANCYFLUX_cahnhilliard_label = 'cahnhilliard', & POROSITY_none_label = 'none', & POROSITY_phasefield_label = 'phasefield', & - HYDROGENFLUX_isoconc_label = 'isoconcentration', & - HYDROGENFLUX_cahnhilliard_label = 'cahnhilliard', & HOMOGENIZATION_none_label = 'none', & HOMOGENIZATION_isostrain_label = 'isostrain', & HOMOGENIZATION_rgc_label = 'rgc' @@ -87,19 +77,14 @@ module material SOURCE_damage_isoBrittle_ID, & SOURCE_damage_isoDuctile_ID, & SOURCE_damage_anisoBrittle_ID, & - SOURCE_damage_anisoDuctile_ID, & - SOURCE_vacancy_phenoplasticity_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID + SOURCE_damage_anisoDuctile_ID end enum enum, bind(c) enumerator :: KINEMATICS_undefined_ID, & KINEMATICS_cleavage_opening_ID, & KINEMATICS_slipplane_opening_ID, & - KINEMATICS_thermal_expansion_ID, & - KINEMATICS_vacancy_strain_ID, & - KINEMATICS_hydrogen_strain_ID + KINEMATICS_thermal_expansion_ID end enum enum, bind(c) @@ -120,20 +105,11 @@ module material DAMAGE_nonlocal_ID end enum - enum, bind(c) - enumerator :: VACANCYFLUX_isoconc_ID, & - VACANCYFLUX_isochempot_ID, & - VACANCYFLUX_cahnhilliard_ID - end enum - enum, bind(c) enumerator :: POROSITY_none_ID, & POROSITY_phasefield_ID end enum - enum, bind(c) - enumerator :: HYDROGENFLUX_isoconc_ID, & - HYDROGENFLUX_cahnhilliard_ID - end enum + enum, bind(c) enumerator :: HOMOGENIZATION_undefined_ID, & @@ -150,12 +126,8 @@ module material thermal_type !< thermal transport model integer(kind(DAMAGE_none_ID)), dimension(:), allocatable, public, protected :: & damage_type !< nonlocal damage model - integer(kind(VACANCYFLUX_isoconc_ID)), dimension(:), allocatable, public, protected :: & - vacancyflux_type !< vacancy transport model integer(kind(POROSITY_none_ID)), dimension(:), allocatable, public, protected :: & porosity_type !< porosity evolution model - integer(kind(HYDROGENFLUX_isoconc_ID)), dimension(:), allocatable, public, protected :: & - hydrogenflux_type !< hydrogen transport model integer(kind(SOURCE_undefined_ID)), dimension(:,:), allocatable, public, protected :: & phase_source, & !< active sources mechanisms of each phase @@ -181,17 +153,13 @@ module material homogenization_typeInstance, & !< instance of particular type of each homogenization thermal_typeInstance, & !< instance of particular type of each thermal transport damage_typeInstance, & !< instance of particular type of each nonlocal damage - vacancyflux_typeInstance, & !< instance of particular type of each vacancy flux porosity_typeInstance, & !< instance of particular type of each porosity model - hydrogenflux_typeInstance, & !< instance of particular type of each hydrogen flux microstructure_crystallite !< crystallite setting ID of each microstructure ! DEPRECATED !!!! real(pReal), dimension(:), allocatable, public, protected :: & thermal_initialT, & !< initial temperature per each homogenization damage_initialPhi, & !< initial damage per each homogenization - vacancyflux_initialCv, & !< initial vacancy concentration per each homogenization - porosity_initialPhi, & !< initial posority per each homogenization - hydrogenflux_initialCh !< initial hydrogen concentration per each homogenization + porosity_initialPhi !< initial posority per each homogenization ! NEW MAPPINGS integer(pInt), dimension(:), allocatable, public, protected :: & @@ -222,9 +190,7 @@ module material homogState, & thermalState, & damageState, & - vacancyfluxState, & - porosityState, & - hydrogenfluxState + porosityState integer(pInt), dimension(:,:,:), allocatable, public, protected :: & material_texture !< texture (index) of each grain,IP,element @@ -275,19 +241,13 @@ module material type(tHomogMapping), allocatable, dimension(:), public :: & thermalMapping, & !< mapping for thermal state/fields damageMapping, & !< mapping for damage state/fields - vacancyfluxMapping, & !< mapping for vacancy conc state/fields - porosityMapping, & !< mapping for porosity state/fields - hydrogenfluxMapping !< mapping for hydrogen conc state/fields + porosityMapping !< mapping for porosity state/fields type(group_float), allocatable, dimension(:), public :: & temperature, & !< temperature field damage, & !< damage field - vacancyConc, & !< vacancy conc field porosity, & !< porosity field - hydrogenConc, & !< hydrogen conc field - temperatureRate, & !< temperature change rate field - vacancyConcRate, & !< vacancy conc change field - hydrogenConcRate !< hydrogen conc change field + temperatureRate !< temperature change rate field public :: & material_init, & @@ -306,14 +266,9 @@ module material SOURCE_damage_isoDuctile_ID, & SOURCE_damage_anisoBrittle_ID, & SOURCE_damage_anisoDuctile_ID, & - SOURCE_vacancy_phenoplasticity_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID, & KINEMATICS_cleavage_opening_ID, & KINEMATICS_slipplane_opening_ID, & KINEMATICS_thermal_expansion_ID, & - KINEMATICS_vacancy_strain_ID, & - KINEMATICS_hydrogen_strain_ID, & STIFFNESS_DEGRADATION_damage_ID, & STIFFNESS_DEGRADATION_porosity_ID, & THERMAL_isothermal_ID, & @@ -322,13 +277,8 @@ module material DAMAGE_none_ID, & DAMAGE_local_ID, & DAMAGE_nonlocal_ID, & - VACANCYFLUX_isoconc_ID, & - VACANCYFLUX_isochempot_ID, & - VACANCYFLUX_cahnhilliard_ID, & POROSITY_none_ID, & POROSITY_phasefield_ID, & - HYDROGENFLUX_isoconc_ID, & - HYDROGENFLUX_cahnhilliard_ID, & HOMOGENIZATION_none_ID, & HOMOGENIZATION_isostrain_ID, & HOMOGENIZATION_RGC_ID @@ -420,25 +370,17 @@ subroutine material_init() allocate(homogState (size(config_homogenization))) allocate(thermalState (size(config_homogenization))) allocate(damageState (size(config_homogenization))) - allocate(vacancyfluxState (size(config_homogenization))) allocate(porosityState (size(config_homogenization))) - allocate(hydrogenfluxState (size(config_homogenization))) allocate(thermalMapping (size(config_homogenization))) allocate(damageMapping (size(config_homogenization))) - allocate(vacancyfluxMapping (size(config_homogenization))) allocate(porosityMapping (size(config_homogenization))) - allocate(hydrogenfluxMapping(size(config_homogenization))) allocate(temperature (size(config_homogenization))) allocate(damage (size(config_homogenization))) - allocate(vacancyConc (size(config_homogenization))) allocate(porosity (size(config_homogenization))) - allocate(hydrogenConc (size(config_homogenization))) allocate(temperatureRate (size(config_homogenization))) - allocate(vacancyConcRate (size(config_homogenization))) - allocate(hydrogenConcRate (size(config_homogenization))) do m = 1_pInt,size(config_microstructure) if(microstructure_crystallite(m) < 1_pInt .or. & @@ -511,17 +453,11 @@ subroutine material_init() do myHomog = 1,size(config_homogenization) thermalMapping (myHomog)%p => mappingHomogenizationConst damageMapping (myHomog)%p => mappingHomogenizationConst - vacancyfluxMapping (myHomog)%p => mappingHomogenizationConst porosityMapping (myHomog)%p => mappingHomogenizationConst - hydrogenfluxMapping(myHomog)%p => mappingHomogenizationConst allocate(temperature (myHomog)%p(1), source=thermal_initialT(myHomog)) allocate(damage (myHomog)%p(1), source=damage_initialPhi(myHomog)) - allocate(vacancyConc (myHomog)%p(1), source=vacancyflux_initialCv(myHomog)) allocate(porosity (myHomog)%p(1), source=porosity_initialPhi(myHomog)) - allocate(hydrogenConc (myHomog)%p(1), source=hydrogenflux_initialCh(myHomog)) allocate(temperatureRate (myHomog)%p(1), source=0.0_pReal) - allocate(vacancyConcRate (myHomog)%p(1), source=0.0_pReal) - allocate(hydrogenConcRate(myHomog)%p(1), source=0.0_pReal) enddo end subroutine material_init @@ -545,23 +481,17 @@ subroutine material_parseHomogenization allocate(homogenization_type(size(config_homogenization)), source=HOMOGENIZATION_undefined_ID) allocate(thermal_type(size(config_homogenization)), source=THERMAL_isothermal_ID) allocate(damage_type (size(config_homogenization)), source=DAMAGE_none_ID) - allocate(vacancyflux_type(size(config_homogenization)), source=VACANCYFLUX_isoconc_ID) allocate(porosity_type (size(config_homogenization)), source=POROSITY_none_ID) - allocate(hydrogenflux_type(size(config_homogenization)), source=HYDROGENFLUX_isoconc_ID) allocate(homogenization_typeInstance(size(config_homogenization)), source=0_pInt) allocate(thermal_typeInstance(size(config_homogenization)), source=0_pInt) allocate(damage_typeInstance(size(config_homogenization)), source=0_pInt) - allocate(vacancyflux_typeInstance(size(config_homogenization)), source=0_pInt) allocate(porosity_typeInstance(size(config_homogenization)), source=0_pInt) - allocate(hydrogenflux_typeInstance(size(config_homogenization)), source=0_pInt) allocate(homogenization_Ngrains(size(config_homogenization)), source=0_pInt) allocate(homogenization_Noutput(size(config_homogenization)), source=0_pInt) allocate(homogenization_active(size(config_homogenization)), source=.false.) !!!!!!!!!!!!!!! allocate(thermal_initialT(size(config_homogenization)), source=300.0_pReal) allocate(damage_initialPhi(size(config_homogenization)), source=1.0_pReal) - allocate(vacancyflux_initialCv(size(config_homogenization)), source=0.0_pReal) allocate(porosity_initialPhi(size(config_homogenization)), source=1.0_pReal) - allocate(hydrogenflux_initialCh(size(config_homogenization)), source=0.0_pReal) forall (h = 1_pInt:size(config_homogenization)) & homogenization_active(h) = any(mesh_homogenizationAt == h) @@ -621,22 +551,7 @@ subroutine material_parseHomogenization endif - if (config_homogenization(h)%keyExists('vacancyflux')) then - vacancyflux_initialCv(h) = config_homogenization(h)%getFloat('cv0',defaultVal=0.0_pReal) - tag = config_homogenization(h)%getString('vacancyflux') - select case (trim(tag)) - case(VACANCYFLUX_isoconc_label) - vacancyflux_type(h) = VACANCYFLUX_isoconc_ID - case(VACANCYFLUX_isochempot_label) - vacancyflux_type(h) = VACANCYFLUX_isochempot_ID - case(VACANCYFLUX_cahnhilliard_label) - vacancyflux_type(h) = VACANCYFLUX_cahnhilliard_ID - case default - call IO_error(500_pInt,ext_msg=trim(tag)) - end select - - endif if (config_homogenization(h)%keyExists('porosity')) then !ToDo? @@ -653,20 +568,7 @@ subroutine material_parseHomogenization endif - if (config_homogenization(h)%keyExists('hydrogenflux')) then - hydrogenflux_initialCh(h) = config_homogenization(h)%getFloat('ch0',defaultVal=0.0_pReal) - tag = config_homogenization(h)%getString('hydrogenflux') - select case (trim(tag)) - case(HYDROGENFLUX_isoconc_label) - hydrogenflux_type(h) = HYDROGENFLUX_isoconc_ID - case(HYDROGENFLUX_cahnhilliard_label) - hydrogenflux_type(h) = HYDROGENFLUX_cahnhilliard_ID - case default - call IO_error(500_pInt,ext_msg=trim(tag)) - end select - - endif enddo @@ -674,9 +576,7 @@ subroutine material_parseHomogenization homogenization_typeInstance(h) = count(homogenization_type(1:h) == homogenization_type(h)) thermal_typeInstance(h) = count(thermal_type (1:h) == thermal_type (h)) damage_typeInstance(h) = count(damage_type (1:h) == damage_type (h)) - vacancyflux_typeInstance(h) = count(vacancyflux_type (1:h) == vacancyflux_type (h)) porosity_typeInstance(h) = count(porosity_type (1:h) == porosity_type (h)) - hydrogenflux_typeInstance(h) = count(hydrogenflux_type (1:h) == hydrogenflux_type (h)) enddo homogenization_maxNgrains = maxval(homogenization_Ngrains,homogenization_active) @@ -866,12 +766,6 @@ subroutine material_parsePhase phase_source(sourceCtr,p) = SOURCE_damage_anisoBrittle_ID case (SOURCE_damage_anisoDuctile_label) phase_source(sourceCtr,p) = SOURCE_damage_anisoDuctile_ID - case (SOURCE_vacancy_phenoplasticity_label) - phase_source(sourceCtr,p) = SOURCE_vacancy_phenoplasticity_ID - case (SOURCE_vacancy_irradiation_label) - phase_source(sourceCtr,p) = SOURCE_vacancy_irradiation_ID - case (SOURCE_vacancy_thermalfluc_label) - phase_source(sourceCtr,p) = SOURCE_vacancy_thermalfluc_ID end select enddo @@ -890,10 +784,6 @@ subroutine material_parsePhase phase_kinematics(kinematicsCtr,p) = KINEMATICS_slipplane_opening_ID case (KINEMATICS_thermal_expansion_label) phase_kinematics(kinematicsCtr,p) = KINEMATICS_thermal_expansion_ID - case (KINEMATICS_vacancy_strain_label) - phase_kinematics(kinematicsCtr,p) = KINEMATICS_vacancy_strain_ID - case (KINEMATICS_hydrogen_strain_label) - phase_kinematics(kinematicsCtr,p) = KINEMATICS_hydrogen_strain_ID end select enddo #if defined(__GFORTRAN__) diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 index 041761afe..fe964d134 100644 --- a/src/source_damage_isoBrittle.f90 +++ b/src/source_damage_isoBrittle.f90 @@ -279,15 +279,7 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) instance = source_damage_isoBrittle_instance(phase) !< instance of damage_isoBrittle source sourceOffset = source_damage_isoBrittle_offset(phase) - stiffness = C - do mech = 1_pInt, phase_NstiffnessDegradations(phase) - select case(phase_stiffnessDegradation(mech,phase)) - case (STIFFNESS_DEGRADATION_porosity_ID) - stiffness = porosity(material_homog(ip,el))%p(porosityMapping(material_homog(ip,el))%p(ip,el))* & - porosity(material_homog(ip,el))%p(porosityMapping(material_homog(ip,el))%p(ip,el))* & - stiffness - end select - enddo + stiffness = C strain = 0.5_pReal*math_Mandel33to6(math_mul33x33(math_transpose33(Fe),Fe)-math_I3) strainenergy = 2.0_pReal*sum(strain*math_mul66x6(stiffness,strain))/ & From 8a27431c6d9e29b8977d786d88cfb350e0637731 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 13:28:16 +0100 Subject: [PATCH 153/372] bugfix bracket falsely removed in last commit --- src/plastic_kinematichardening.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index edd0d3a8e..8cbf80726 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -540,8 +540,9 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) do j = 1_pInt, prm%totalNslip dot%crss(j,of) = dot_product(prm%interaction_SlipSlip(j,:),dot%accshear(:,of)) & - * ( prm%theta1(j) + prm%theta0(j) - prm%theta1(j) & - + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)*exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & + * ( prm%theta1(j) & + + (prm%theta0(j) - prm%theta1(j) + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)) & + *exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & ) enddo dot%crss_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & From c97a46826a943f7c7ae0eee09e3fb6ab6047f64f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 14:11:34 +0100 Subject: [PATCH 154/372] simplified --- src/plastic_kinematichardening.f90 | 95 ++++++++++-------------------- 1 file changed, 32 insertions(+), 63 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 8cbf80726..2a9245140 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -89,8 +89,7 @@ module plastic_kinehardening type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & deltaState, & - state, & - state0 + state public :: & @@ -144,7 +143,6 @@ subroutine plastic_kinehardening_init output_ID integer(pInt) :: & o, i, p, & - phase, & instance, & Ninstance, & NipcMyPhase, & @@ -190,7 +188,6 @@ subroutine plastic_kinehardening_init allocate(param(Ninstance)) ! one container of parameters per instance allocate(paramNew(Ninstance)) allocate(state(Ninstance)) - allocate(state0(Ninstance)) allocate(dotState(Ninstance)) allocate(deltaState(Ninstance)) @@ -242,7 +239,7 @@ subroutine plastic_kinehardening_init prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) ! expand: family => system - !prm%crss0 = math_expand(prm%crss0, prm%Nslip) + prm%crss0 = math_expand(prm%crss0, prm%Nslip) prm%tau1 = math_expand(prm%tau1,prm%Nslip) prm%tau1_b = math_expand(prm%tau1_b, prm%Nslip) prm%theta0 = math_expand(prm%theta0,prm%Nslip) @@ -304,7 +301,7 @@ subroutine plastic_kinehardening_init ! allocate state arrays NipcMyPhase = count(material_phase == p) ! number of constituents with my phase sizeDotState = size(['crss ','crss_back', 'accshear ']) * prm%TotalNslip - sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0']) * prm%TotalNslip + sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0' ]) * prm%TotalNslip sizeState = sizeDotState + sizeDeltaState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & @@ -318,6 +315,7 @@ subroutine plastic_kinehardening_init endIndex = nSlip stt%crss => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) dot%crss => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) + stt%crss = spread(prm%crss0, 2, NipcMyPhase) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance startIndex = endIndex + 1_pInt @@ -350,17 +348,19 @@ subroutine plastic_kinehardening_init endIndex = endIndex + nSlip stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + + offset_slip = plasticState(p)%nSlip + plasticState(p)%slipRate => & + plasticState(p)%dotState(offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) + plasticState(p)%accumulatedSlip => & + plasticState(p)%state(offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) + end associate end do - - -!-------------------------------------------------------------------------------------------------- -! allocation of variables whose size depends on the total number of active slip systems - initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config - myPhase2: if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then ! only consider my phase - NipcMyPhase = count(material_phase == phase) ! number of IPCs containing my phase - instance = phase_plasticityInstance(phase) ! which instance of my phase + end subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! sanity checks @@ -373,33 +373,7 @@ subroutine plastic_kinehardening_init ! .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' ! if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' ! if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' - if (extmsg /= '') then - extmsg = trim(extmsg)//' ('//PLASTICITY_KINEHARDENING_label//')' ! prepare error message identifier - call IO_error(211_pInt,ip=instance,ext_msg=extmsg) - endif - - - offset_slip = plasticState(phase)%nSlip - plasticState(phase)%slipRate => & - plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) - plasticState(phase)%accumulatedSlip => & - plasticState(phase)%state(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) - - endindex = 0_pInt - o = endIndex ! offset of dotstate index relative to state index - - startIndex = endIndex + 1_pInt - endIndex = endIndex + paramNew(instance)%totalNslip - state0 (instance)%crss => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) - - state0(instance)%crss = spread(math_expand(paramNew(instance)%crss0,& - paramNew(instance)%Nslip), & - 2, NipcMyPhase) - endif myPhase2 - enddo initializeInstances - -end subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- @@ -427,15 +401,13 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & - tau_pos,tau_neg, & dgdot_dtau_pos,dgdot_dtau_neg associate(prm => paramNew(instance), stt => state(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of,dgdot_dtau_pos,dgdot_dtau_neg) + call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) do j = 1_pInt, prm%totalNslip Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) @@ -466,11 +438,9 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) real(pReal), dimension(paramNew(instance)%totalNslip) :: & gdot_pos,gdot_neg, & - tau_pos,tau_neg, & sense - call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) + call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction @@ -523,18 +493,14 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) j real(pReal), dimension(paramNew(instance)%totalNslip) :: & - gdot_pos,gdot_neg, & - tau_pos,tau_neg + gdot_pos,gdot_neg real(pReal) :: & sumGamma associate( prm => paramNew(instance), stt => state(instance), dot => dotState(instance)) - - call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) - + call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) @@ -577,15 +543,16 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) o,c,j real(pReal), dimension(paramNew(instance)%totalNslip) :: & - gdot_pos,gdot_neg, & - tau_pos,tau_neg + gdot_pos,gdot_neg postResults = 0.0_pReal c = 0_pInt - call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of) + associate( prm => paramNew(instance), stt => state(instance)) + + call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) + outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(prm%outputID(o)) case (crss_ID) @@ -613,10 +580,12 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) c = c + prm%totalNslip case (shearrate_ID) + postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg c = c + prm%totalNslip case (resolvedstress_ID) + do j = 1_pInt, prm%totalNslip postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) enddo @@ -709,9 +678,8 @@ end subroutine kinetics !-------------------------------------------------------------------------------------------------- !> @brief calculation of shear rates (\dot \gamma) !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & - Mp,instance,of, dgdot_dtau_pos, & - dgdot_dtau_neg) +subroutine plastic_kinehardening_shearRates(Mp,instance,of, & + gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) use prec use math @@ -723,13 +691,13 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & of !< index of phaseMember real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & gdot_pos, & !< shear rates from positive line segments - gdot_neg, & !< shear rates from negative line segments - tau_pos, & !< shear stress on positive line segments - tau_neg !< shear stress on negative line segments + gdot_neg !< shear rates from negative line segments real(pReal), dimension(paramNew(instance)%totalNslip), intent(out),optional :: & dgdot_dtau_pos, & dgdot_dtau_neg - + real(pReal), dimension(paramNew(instance)%totalNslip) :: & + tau_pos, & !< shear stress on positive line segments + tau_neg !< shear stress on negative line segments integer(pInt) :: & i @@ -741,6 +709,7 @@ subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & tau_pos = tau_pos - stt%crss_back(:,of) tau_neg = tau_neg - stt%crss_back(:,of) + gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) From b46a5b3135883e18e241d8a16da3a29bd866190e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 14:47:02 +0100 Subject: [PATCH 155/372] save space --- src/plastic_kinematichardening.f90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 2a9245140..8188c1480 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -440,6 +440,8 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) gdot_pos,gdot_neg, & sense + associate( prm => paramNew(instance), stt => state(instance), del => deltaState(instance)) + call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined @@ -463,15 +465,17 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) #endif !-------------------------------------------------------------------------------------------------- ! switch in sense of shear? - where(dNeq(sense,state(instance)%sense(:,of),0.1_pReal)) - deltaState(instance)%sense (:,of) = sense - state(instance)%sense(:,of) ! switch sense - deltaState(instance)%chi0 (:,of) = abs(state(instance)%crss_back(:,of)) - state(instance)%chi0(:,of) ! remember current backstress magnitude - deltaState(instance)%gamma0(:,of) = state(instance)%accshear(:,of) - state(instance)%gamma0(:,of) ! remember current accumulated shear + where(dNeq(sense,stt%sense(:,of),0.1_pReal)) + del%sense (:,of) = sense - stt%sense(:,of) ! switch sense + del%chi0 (:,of) = abs(stt%crss_back(:,of)) - stt%chi0(:,of) ! remember current backstress magnitude + del%gamma0(:,of) = stt%accshear(:,of) - stt%gamma0(:,of) ! remember current accumulated shear else where - deltaState(instance)%sense (:,of) = 0.0_pReal ! no change - deltaState(instance)%chi0 (:,of) = 0.0_pReal - deltaState(instance)%gamma0(:,of) = 0.0_pReal + del%sense (:,of) = 0.0_pReal + del%chi0 (:,of) = 0.0_pReal + del%gamma0(:,of) = 0.0_pReal end where + + end associate end subroutine plastic_kinehardening_deltaState From e5ef7edbd2f80b1689525b2341f045837932c3fe Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 22 Dec 2018 15:22:41 +0100 Subject: [PATCH 156/372] kinetics similar to phenopowerlaw --- src/plastic_kinematichardening.f90 | 138 +++++++---------------------- 1 file changed, 32 insertions(+), 106 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 8188c1480..58c8c4529 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -83,8 +83,7 @@ module plastic_kinehardening end type type(tParameters), dimension(:), allocatable, private :: & - param, & !< containers of constitutive parameters (len Ninstance) - paramNew ! temp + param !< containers of constitutive parameters (len Ninstance) type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & @@ -99,7 +98,7 @@ module plastic_kinehardening plastic_kinehardening_deltaState, & plastic_kinehardening_postResults private :: & - plastic_kinehardening_shearRates + kinetics contains @@ -149,7 +148,6 @@ subroutine plastic_kinehardening_init outputSize, & offset_slip, & startIndex, endIndex, & - nSlip, & sizeDotState, & sizeState, & sizeDeltaState @@ -164,7 +162,6 @@ subroutine plastic_kinehardening_init character(len=65536), dimension(:), allocatable :: & outputs character(len=65536) :: & - tag = '', & extmsg = '', & structure = '' @@ -186,7 +183,6 @@ subroutine plastic_kinehardening_init allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,Ninstance), source=0_pInt) allocate(param(Ninstance)) ! one container of parameters per instance - allocate(paramNew(Ninstance)) allocate(state(Ninstance)) allocate(dotState(Ninstance)) allocate(deltaState(Ninstance)) @@ -194,7 +190,7 @@ subroutine plastic_kinehardening_init do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle instance = phase_plasticityInstance(p) ! which instance of my phase - associate(prm => paramNew(phase_plasticityInstance(p)), & + associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & delta => deltaState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p))) @@ -295,8 +291,7 @@ subroutine plastic_kinehardening_init endif end do - param(instance)%outputID = prm%outputID - nslip = prm%totalNslip + !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) ! number of constituents with my phase @@ -305,27 +300,27 @@ subroutine plastic_kinehardening_init sizeState = sizeDotState + sizeDeltaState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & - nSlip,0_pInt,0_pInt) + prm%totalNslip,0_pInt,0_pInt) plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) plasticState(p)%offsetDeltaState = sizeDotState startIndex = 1_pInt - endIndex = nSlip + endIndex = prm%totalNslip stt%crss => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) dot%crss => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) stt%crss = spread(prm%crss0, 2, NipcMyPhase) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + prm%totalNslip stt%crss_back => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) dot%crss_back => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + prm%totalNslip stt%accshear => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) dot%accshear => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear @@ -335,17 +330,17 @@ subroutine plastic_kinehardening_init o = endIndex startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + prm%totalNslip stt%sense => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + prm%totalNslip stt%chi0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) startIndex = endIndex + 1_pInt - endIndex = endIndex + nSlip + endIndex = endIndex + prm%totalNslip stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) @@ -399,15 +394,15 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) j,k,l,m,n - real(pReal), dimension(paramNew(instance)%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg, & dgdot_dtau_pos,dgdot_dtau_neg - associate(prm => paramNew(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance)) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) + call kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) do j = 1_pInt, prm%totalNslip Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) @@ -436,33 +431,30 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) instance, & of - real(pReal), dimension(paramNew(instance)%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg, & sense - associate( prm => paramNew(instance), stt => state(instance), del => deltaState(instance)) + associate( prm => param(instance), stt => state(instance), del => deltaState(instance)) - call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined 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_pInt & ! ToDo: We need an inverse mapping of ->el, ip, co ! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & ! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then ! write(6,'(a)') '======= kinehardening delta state =======' ! endif -#endif - - -#ifdef DEBUG ! if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & ! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & ! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then ! write(6,'(i2,1x,f7.4,1x,f7.4)') j,sense(j),state(instance)%sense(j,of) ! endif #endif + !-------------------------------------------------------------------------------------------------- ! switch in sense of shear? where(dNeq(sense,stt%sense(:,of),0.1_pReal)) @@ -480,7 +472,6 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) end subroutine plastic_kinehardening_deltaState - !-------------------------------------------------------------------------------------------------- !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- @@ -491,20 +482,19 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) Mp !< Mandel stress integer(pInt), intent(in) :: & instance, & - of !< element !< microstructure state + of integer(pInt) :: & j - - real(pReal), dimension(paramNew(instance)%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg real(pReal) :: & sumGamma - associate( prm => paramNew(instance), stt => state(instance), dot => dotState(instance)) + associate( prm => param(instance), stt => state(instance), dot => dotState(instance)) - call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) @@ -546,16 +536,16 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) integer(pInt) :: & o,c,j - real(pReal), dimension(paramNew(instance)%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg postResults = 0.0_pReal c = 0_pInt - associate( prm => paramNew(instance), stt => state(instance)) + associate( prm => param(instance), stt => state(instance)) - call plastic_kinehardening_shearRates(Mp,instance,of,gdot_pos,gdot_neg) + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) select case(prm%outputID(o)) @@ -584,12 +574,10 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) c = c + prm%totalNslip case (shearrate_ID) - postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg c = c + prm%totalNslip case (resolvedstress_ID) - do j = 1_pInt, prm%totalNslip postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) enddo @@ -619,33 +607,30 @@ pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_d integer(pInt), intent(in) :: & instance, & of - real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & + real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & gdot_pos, & gdot_neg - real(pReal), dimension(paramNew(instance)%totalNslip), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNslip), optional, intent(out) :: & dgdot_dtau_pos, & dgdot_dtau_neg - real(pReal), dimension(paramNew(instance)%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip) :: & tau_pos, & tau_neg integer(pInt) :: i logical :: nonSchmidActive - associate( prm => paramNew(instance), stt => state(instance)) + associate( prm => param(instance), stt => state(instance)) nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt do i = 1_pInt, prm%totalNslip - tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) - tau_neg(i) = merge(math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)), & + 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) enddo - tau_pos = tau_pos - stt%crss_back(:,of) - tau_neg = tau_neg - stt%crss_back(:,of) - where(dNeq0(tau_pos)) gdot_pos = prm%gdot0 * merge(0.5_pReal,1.0_pReal, nonSchmidActive) & ! 1/2 if non-Schmid active * sign(abs(tau_pos/stt%crss(:,of))**prm%n_slip, tau_pos) @@ -678,63 +663,4 @@ pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_d end subroutine kinetics - -!-------------------------------------------------------------------------------------------------- -!> @brief calculation of shear rates (\dot \gamma) -!-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_shearRates(Mp,instance,of, & - gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) - use prec - use math - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp - integer(pInt), intent(in) :: & - instance, & !< instance of that phase - of !< index of phaseMember - real(pReal), dimension(paramNew(instance)%totalNslip), intent(out) :: & - gdot_pos, & !< shear rates from positive line segments - gdot_neg !< shear rates from negative line segments - real(pReal), dimension(paramNew(instance)%totalNslip), intent(out),optional :: & - dgdot_dtau_pos, & - dgdot_dtau_neg - real(pReal), dimension(paramNew(instance)%totalNslip) :: & - tau_pos, & !< shear stress on positive line segments - tau_neg !< shear stress on negative line segments - integer(pInt) :: & - i - - associate(prm => paramNew(instance), stt => state(instance)) - do i = 1_pInt, prm%totalNslip - tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) - tau_neg(i) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) - enddo - - tau_pos = tau_pos - stt%crss_back(:,of) - tau_neg = tau_neg - stt%crss_back(:,of) - - - gdot_pos = sign(0.5_pReal * prm%gdot0 *(abs(tau_pos)/ state(instance)%crss(:,of))**prm%n_slip,tau_pos) - gdot_neg = sign(0.5_pReal * prm%gdot0 *(abs(tau_neg)/ state(instance)%crss(:,of))**prm%n_slip,tau_neg) - - if (present(dgdot_dtau_pos)) then - where(dNeq0(gdot_pos)) - dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos - else where - dgdot_dtau_pos = 0.0_pReal - end where - endif - if (present(dgdot_dtau_neg)) then - where(dNeq0(gdot_neg)) - dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg - else where - dgdot_dtau_neg = 0.0_pReal - end where - endif - -end associate - -end subroutine plastic_kinehardening_shearRates - end module plastic_kinehardening From fa88065591695e82c3e93f8d0c9c771a760adfa1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 25 Dec 2018 14:20:01 +0100 Subject: [PATCH 157/372] small polishing --- src/plastic_kinematichardening.f90 | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 58c8c4529..d8076d1a9 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -374,9 +374,7 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - use prec, only: & - dNeq0 +pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(out) :: & @@ -392,13 +390,12 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) integer(pInt) :: & j,k,l,m,n - - real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg, & dgdot_dtau_pos,dgdot_dtau_neg associate(prm => param(instance), stt => state(instance)) + Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -411,7 +408,8 @@ subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) + dgdot_dtau_pos(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) & + dgdot_dtau_neg(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) enddo -end associate + + end associate end subroutine plastic_kinehardening_LpAndItsTangent @@ -628,7 +626,7 @@ pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_d do i = 1_pInt, 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) + 0.0_pReal, nonSchmidActive) enddo where(dNeq0(tau_pos)) From ed79c7f75c9777c92f75838181fcf4a81377a53a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 10:41:11 +0100 Subject: [PATCH 158/372] all not compatible with new structure --- src/constitutive.f90 | 7 +- src/hydrogenflux_cahnhilliard.f90 | 508 --------------------- src/hydrogenflux_isoconc.f90 | 62 --- src/kinematics_hydrogen_strain.f90 | 263 ----------- src/kinematics_vacancy_strain.f90 | 264 ----------- src/material.f90 | 58 +-- src/porosity_none.f90 | 60 --- src/porosity_phasefield.f90 | 448 ------------------ src/source_damage_isoBrittle.f90 | 5 +- src/source_vacancy_irradiation.f90 | 248 ---------- src/source_vacancy_phenoplasticity.f90 | 210 --------- src/source_vacancy_thermalfluc.f90 | 250 ---------- src/vacancyflux_cahnhilliard.f90 | 602 ------------------------- src/vacancyflux_isochempot.f90 | 328 -------------- src/vacancyflux_isoconc.f90 | 62 --- 15 files changed, 6 insertions(+), 3369 deletions(-) delete mode 100644 src/hydrogenflux_cahnhilliard.f90 delete mode 100644 src/hydrogenflux_isoconc.f90 delete mode 100644 src/kinematics_hydrogen_strain.f90 delete mode 100644 src/kinematics_vacancy_strain.f90 delete mode 100644 src/porosity_none.f90 delete mode 100644 src/porosity_phasefield.f90 delete mode 100644 src/source_vacancy_irradiation.f90 delete mode 100644 src/source_vacancy_phenoplasticity.f90 delete mode 100644 src/source_vacancy_thermalfluc.f90 delete mode 100644 src/vacancyflux_cahnhilliard.f90 delete mode 100644 src/vacancyflux_isochempot.f90 delete mode 100644 src/vacancyflux_isoconc.f90 diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 040f3c39e..ce98ced36 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -716,10 +716,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip phase_stiffnessDegradation, & damage, & damageMapping, & - porosity, & - porosityMapping, & - STIFFNESS_DEGRADATION_damage_ID, & - STIFFNESS_DEGRADATION_porosity_ID + STIFFNESS_DEGRADATION_damage_ID implicit none integer(pInt), intent(in) :: & @@ -749,8 +746,6 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip degradationType: select case(phase_stiffnessDegradation(d,material_phase(ipc,ip,el))) case (STIFFNESS_DEGRADATION_damage_ID) degradationType C = C * damage(ho)%p(damageMapping(ho)%p(ip,el))**2_pInt - case (STIFFNESS_DEGRADATION_porosity_ID) degradationType - C = C * porosity(ho)%p(porosityMapping(ho)%p(ip,el))**2_pInt end select degradationType enddo DegradationLoop diff --git a/src/hydrogenflux_cahnhilliard.f90 b/src/hydrogenflux_cahnhilliard.f90 deleted file mode 100644 index 3a42a49e1..000000000 --- a/src/hydrogenflux_cahnhilliard.f90 +++ /dev/null @@ -1,508 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for conservative transport of solute hydrogen -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module hydrogenflux_cahnhilliard - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - hydrogenflux_cahnhilliard_sizePostResults !< cumulative size of post results - - integer(pInt), dimension(:,:), allocatable, target, public :: & - hydrogenflux_cahnhilliard_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - hydrogenflux_cahnhilliard_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - hydrogenflux_cahnhilliard_Noutput !< number of outputs per instance of this damage - - real(pReal), parameter, private :: & - kB = 1.3806488e-23_pReal !< Boltzmann constant in J/Kelvin - - enum, bind(c) - enumerator :: undefined_ID, & - hydrogenConc_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - hydrogenflux_cahnhilliard_outputID !< ID of each post result output - - - public :: & - hydrogenflux_cahnhilliard_init, & - hydrogenflux_cahnhilliard_getMobility33, & - hydrogenflux_cahnhilliard_getDiffusion33, & - hydrogenflux_cahnhilliard_getFormationEnergy, & - hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent, & - hydrogenflux_cahnhilliard_getChemPotAndItsTangent, & - hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate, & - hydrogenflux_cahnhilliard_postResults - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine hydrogenflux_cahnhilliard_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - hydrogenflux_type, & - hydrogenflux_typeInstance, & - homogenization_Noutput, & - HYDROGENFLUX_cahnhilliard_label, & - HYDROGENFLUX_cahnhilliard_ID, & - material_homog, & - mappingHomogenization, & - hydrogenfluxState, & - hydrogenfluxMapping, & - hydrogenConc, & - hydrogenConcRate, & - hydrogenflux_initialCh - use config, only: & - material_partHomogenization, & - material_partPhase - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- hydrogenflux_'//HYDROGENFLUX_cahnhilliard_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(hydrogenflux_type == HYDROGENFLUX_cahnhilliard_ID),pInt) - if (maxNinstance == 0_pInt) return - - allocate(hydrogenflux_cahnhilliard_sizePostResults(maxNinstance), source=0_pInt) - allocate(hydrogenflux_cahnhilliard_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(hydrogenflux_cahnhilliard_output (maxval(homogenization_Noutput),maxNinstance)) - hydrogenflux_cahnhilliard_output = '' - allocate(hydrogenflux_cahnhilliard_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(hydrogenflux_cahnhilliard_Noutput (maxNinstance), source=0_pInt) - - rewind(fileUnit) - section = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to - line = IO_read(fileUnit) - enddo - - parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next homog section - section = section + 1_pInt ! advance homog section counter - cycle ! skip to next line - endif - - if (section > 0_pInt ) then; if (hydrogenflux_type(section) == HYDROGENFLUX_cahnhilliard_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = hydrogenflux_typeInstance(section) ! which instance of my hydrogenflux is present homog - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('hydrogenconc') - hydrogenflux_cahnhilliard_Noutput(instance) = hydrogenflux_cahnhilliard_Noutput(instance) + 1_pInt - hydrogenflux_cahnhilliard_outputID(hydrogenflux_cahnhilliard_Noutput(instance),instance) = hydrogenConc_ID - hydrogenflux_cahnhilliard_output(hydrogenflux_cahnhilliard_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select - - end select - endif; endif - enddo parsingHomog - - rewind(fileUnit) - section = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - initializeInstances: do section = 1_pInt, size(hydrogenflux_type) - if (hydrogenflux_type(section) == HYDROGENFLUX_cahnhilliard_ID) then - NofMyHomog=count(material_homog==section) - instance = hydrogenflux_typeInstance(section) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,hydrogenflux_cahnhilliard_Noutput(instance) - select case(hydrogenflux_cahnhilliard_outputID(o,instance)) - case(hydrogenConc_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - hydrogenflux_cahnhilliard_sizePostResult(o,instance) = mySize - hydrogenflux_cahnhilliard_sizePostResults(instance) = hydrogenflux_cahnhilliard_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -! allocate state arrays - sizeState = 0_pInt - hydrogenfluxState(section)%sizeState = sizeState - hydrogenfluxState(section)%sizePostResults = hydrogenflux_cahnhilliard_sizePostResults(instance) - allocate(hydrogenfluxState(section)%state0 (sizeState,NofMyHomog)) - allocate(hydrogenfluxState(section)%subState0(sizeState,NofMyHomog)) - allocate(hydrogenfluxState(section)%state (sizeState,NofMyHomog)) - - nullify(hydrogenfluxMapping(section)%p) - hydrogenfluxMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(hydrogenConc (section)%p) - deallocate(hydrogenConcRate(section)%p) - allocate (hydrogenConc (section)%p(NofMyHomog), source=hydrogenflux_initialCh(section)) - allocate (hydrogenConcRate(section)%p(NofMyHomog), source=0.0_pReal) - - endif - - enddo initializeInstances - -end subroutine hydrogenflux_cahnhilliard_init - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized solute mobility tensor in reference configuration -!-------------------------------------------------------------------------------------------------- -function hydrogenflux_cahnhilliard_getMobility33(ip,el) - use lattice, only: & - lattice_hydrogenfluxMobility33 - 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) :: & - hydrogenflux_cahnhilliard_getMobility33 - integer(pInt) :: & - grain - - hydrogenflux_cahnhilliard_getMobility33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - hydrogenflux_cahnhilliard_getMobility33 = hydrogenflux_cahnhilliard_getMobility33 + & - crystallite_push33ToRef(grain,ip,el,lattice_hydrogenfluxMobility33(:,:,material_phase(grain,ip,el))) - enddo - - hydrogenflux_cahnhilliard_getMobility33 = & - hydrogenflux_cahnhilliard_getMobility33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function hydrogenflux_cahnhilliard_getMobility33 - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized solute nonlocal diffusion tensor in reference configuration -!-------------------------------------------------------------------------------------------------- -function hydrogenflux_cahnhilliard_getDiffusion33(ip,el) - use lattice, only: & - lattice_hydrogenfluxDiffusion33 - 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) :: & - hydrogenflux_cahnhilliard_getDiffusion33 - integer(pInt) :: & - grain - - hydrogenflux_cahnhilliard_getDiffusion33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - hydrogenflux_cahnhilliard_getDiffusion33 = hydrogenflux_cahnhilliard_getDiffusion33 + & - crystallite_push33ToRef(grain,ip,el,lattice_hydrogenfluxDiffusion33(:,:,material_phase(grain,ip,el))) - enddo - - hydrogenflux_cahnhilliard_getDiffusion33 = & - hydrogenflux_cahnhilliard_getDiffusion33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function hydrogenflux_cahnhilliard_getDiffusion33 - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized solution energy -!-------------------------------------------------------------------------------------------------- -function hydrogenflux_cahnhilliard_getFormationEnergy(ip,el) - use lattice, only: & - lattice_hydrogenFormationEnergy, & - lattice_hydrogenVol, & - lattice_hydrogenSurfaceEnergy - 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) :: & - hydrogenflux_cahnhilliard_getFormationEnergy - integer(pInt) :: & - grain - - hydrogenflux_cahnhilliard_getFormationEnergy = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - hydrogenflux_cahnhilliard_getFormationEnergy = hydrogenflux_cahnhilliard_getFormationEnergy + & - lattice_hydrogenFormationEnergy(material_phase(grain,ip,el))/ & - lattice_hydrogenVol(material_phase(grain,ip,el))/ & - lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) - enddo - - hydrogenflux_cahnhilliard_getFormationEnergy = & - hydrogenflux_cahnhilliard_getFormationEnergy/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function hydrogenflux_cahnhilliard_getFormationEnergy - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized hydrogen entropy coefficient -!-------------------------------------------------------------------------------------------------- -function hydrogenflux_cahnhilliard_getEntropicCoeff(ip,el) - use lattice, only: & - lattice_hydrogenVol, & - lattice_hydrogenSurfaceEnergy - use material, only: & - homogenization_Ngrains, & - material_homog, & - material_phase, & - temperature, & - thermalMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal) :: & - hydrogenflux_cahnhilliard_getEntropicCoeff - integer(pInt) :: & - grain - - hydrogenflux_cahnhilliard_getEntropicCoeff = 0.0_pReal - do grain = 1, homogenization_Ngrains(material_homog(ip,el)) - hydrogenflux_cahnhilliard_getEntropicCoeff = hydrogenflux_cahnhilliard_getEntropicCoeff + & - kB/ & - lattice_hydrogenVol(material_phase(grain,ip,el))/ & - lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) - enddo - - hydrogenflux_cahnhilliard_getEntropicCoeff = hydrogenflux_cahnhilliard_getEntropicCoeff* & - temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))/ & - real(homogenization_Ngrains(material_homog(ip,el)),pReal) - -end function hydrogenflux_cahnhilliard_getEntropicCoeff - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized kinematic contribution to chemical potential -!-------------------------------------------------------------------------------------------------- -subroutine hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCh, Ch, ip, el) - use lattice, only: & - lattice_hydrogenSurfaceEnergy - use material, only: & - homogenization_Ngrains, & - material_homog, & - phase_kinematics, & - phase_Nkinematics, & - material_phase, & - KINEMATICS_hydrogen_strain_ID - use crystallite, only: & - crystallite_Tstar_v, & - crystallite_Fi0, & - crystallite_Fi - use kinematics_hydrogen_strain, only: & - kinematics_hydrogen_strain_ChemPotAndItsTangent - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Ch - real(pReal), intent(out) :: & - KPot, dKPot_dCh - real(pReal) :: & - my_KPot, my_dKPot_dCh - integer(pInt) :: & - grain, kinematics - - KPot = 0.0_pReal - dKPot_dCh = 0.0_pReal - do grain = 1_pInt,homogenization_Ngrains(material_homog(ip,el)) - do kinematics = 1_pInt, phase_Nkinematics(material_phase(grain,ip,el)) - select case (phase_kinematics(kinematics,material_phase(grain,ip,el))) - case (KINEMATICS_hydrogen_strain_ID) - call kinematics_hydrogen_strain_ChemPotAndItsTangent(my_KPot, my_dKPot_dCh, & - crystallite_Tstar_v(1:6,grain,ip,el), & - crystallite_Fi0(1:3,1:3,grain,ip,el), & - crystallite_Fi (1:3,1:3,grain,ip,el), & - grain,ip, el) - - case default - my_KPot = 0.0_pReal - my_dKPot_dCh = 0.0_pReal - - end select - KPot = KPot + my_KPot/lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) - dKPot_dCh = dKPot_dCh + my_dKPot_dCh/lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) - enddo - enddo - - KPot = KPot/real(homogenization_Ngrains(material_homog(ip,el)),pReal) - dKPot_dCh = dKPot_dCh/real(homogenization_Ngrains(material_homog(ip,el)),pReal) - -end subroutine hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized chemical potential -!-------------------------------------------------------------------------------------------------- -subroutine hydrogenflux_cahnhilliard_getChemPotAndItsTangent(ChemPot,dChemPot_dCh,Ch,ip,el) - use numerics, only: & - hydrogenBoundPenalty, & - hydrogenPolyOrder - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Ch - real(pReal), intent(out) :: & - ChemPot, & - dChemPot_dCh - real(pReal) :: & - kBT, KPot, dKPot_dCh - integer(pInt) :: & - o - - ChemPot = hydrogenflux_cahnhilliard_getFormationEnergy(ip,el) - dChemPot_dCh = 0.0_pReal - kBT = hydrogenflux_cahnhilliard_getEntropicCoeff(ip,el) - do o = 1_pInt, hydrogenPolyOrder - ChemPot = ChemPot + kBT*((2.0_pReal*Ch - 1.0_pReal)**real(2_pInt*o-1_pInt,pReal))/ & - real(2_pInt*o-1_pInt,pReal) - dChemPot_dCh = dChemPot_dCh + 2.0_pReal*kBT*(2.0_pReal*Ch - 1.0_pReal)**real(2_pInt*o-2_pInt,pReal) - enddo - - call hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCh, Ch, ip, el) - ChemPot = ChemPot + KPot - dChemPot_dCh = dChemPot_dCh + dKPot_dCh - - if (Ch < 0.0_pReal) then - ChemPot = ChemPot - 3.0_pReal*hydrogenBoundPenalty*Ch*Ch - dChemPot_dCh = dChemPot_dCh - 6.0_pReal*hydrogenBoundPenalty*Ch - elseif (Ch > 1.0_pReal) then - ChemPot = ChemPot + 3.0_pReal*hydrogenBoundPenalty*(1.0_pReal - Ch)*(1.0_pReal - Ch) - dChemPot_dCh = dChemPot_dCh - 6.0_pReal*hydrogenBoundPenalty*(1.0_pReal - Ch) - endif - -end subroutine hydrogenflux_cahnhilliard_getChemPotAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief updates hydrogen concentration with solution from Cahn-Hilliard PDE for solute transport -!-------------------------------------------------------------------------------------------------- -subroutine hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate(Ch,Chdot,ip,el) - use material, only: & - mappingHomogenization, & - hydrogenConc, & - hydrogenConcRate, & - hydrogenfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Ch, & - Chdot - integer(pInt) :: & - homog, & - offset - - homog = mappingHomogenization(2,ip,el) - offset = hydrogenfluxMapping(homog)%p(ip,el) - hydrogenConc (homog)%p(offset) = Ch - hydrogenConcRate(homog)%p(offset) = Chdot - -end subroutine hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of hydrogen transport results -!-------------------------------------------------------------------------------------------------- -function hydrogenflux_cahnhilliard_postResults(ip,el) - use material, only: & - mappingHomogenization, & - hydrogenflux_typeInstance, & - hydrogenConc, & - hydrogenfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point - el !< element - real(pReal), dimension(hydrogenflux_cahnhilliard_sizePostResults(hydrogenflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & - hydrogenflux_cahnhilliard_postResults - - integer(pInt) :: & - instance, homog, offset, o, c - - homog = mappingHomogenization(2,ip,el) - offset = hydrogenfluxMapping(homog)%p(ip,el) - instance = hydrogenflux_typeInstance(homog) - - c = 0_pInt - hydrogenflux_cahnhilliard_postResults = 0.0_pReal - - do o = 1_pInt,hydrogenflux_cahnhilliard_Noutput(instance) - select case(hydrogenflux_cahnhilliard_outputID(o,instance)) - - case (hydrogenConc_ID) - hydrogenflux_cahnhilliard_postResults(c+1_pInt) = hydrogenConc(homog)%p(offset) - c = c + 1 - end select - enddo -end function hydrogenflux_cahnhilliard_postResults - -end module hydrogenflux_cahnhilliard diff --git a/src/hydrogenflux_isoconc.f90 b/src/hydrogenflux_isoconc.f90 deleted file mode 100644 index 836d29198..000000000 --- a/src/hydrogenflux_isoconc.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for constant hydrogen concentration -!-------------------------------------------------------------------------------------------------- -module hydrogenflux_isoconc - - implicit none - private - - public :: & - hydrogenflux_isoconc_init - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all neccessary fields, reads information from material configuration file -!-------------------------------------------------------------------------------------------------- -subroutine hydrogenflux_isoconc_init() -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use prec, only: & - pReal, & - pInt - use IO, only: & - IO_timeStamp - use material - use config - - implicit none - integer(pInt) :: & - homog, & - NofMyHomog - - write(6,'(/,a)') ' <<<+- hydrogenflux_'//HYDROGENFLUX_isoconc_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - initializeInstances: do homog = 1_pInt, material_Nhomogenization - - myhomog: if (hydrogenflux_type(homog) == HYDROGENFLUX_isoconc_ID) then - NofMyHomog = count(material_homog == homog) - hydrogenfluxState(homog)%sizeState = 0_pInt - hydrogenfluxState(homog)%sizePostResults = 0_pInt - allocate(hydrogenfluxState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(hydrogenfluxState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(hydrogenfluxState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) - - deallocate(hydrogenConc (homog)%p) - deallocate(hydrogenConcRate(homog)%p) - allocate (hydrogenConc (homog)%p(1), source=hydrogenflux_initialCh(homog)) - allocate (hydrogenConcRate(homog)%p(1), source=0.0_pReal) - - endif myhomog - enddo initializeInstances - - -end subroutine hydrogenflux_isoconc_init - -end module hydrogenflux_isoconc diff --git a/src/kinematics_hydrogen_strain.f90 b/src/kinematics_hydrogen_strain.f90 deleted file mode 100644 index 516ca286f..000000000 --- a/src/kinematics_hydrogen_strain.f90 +++ /dev/null @@ -1,263 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine incorporating kinematics resulting from interstitial hydrogen -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module kinematics_hydrogen_strain - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - kinematics_hydrogen_strain_sizePostResults, & !< cumulative size of post results - kinematics_hydrogen_strain_offset, & !< which kinematics is my current damage mechanism? - kinematics_hydrogen_strain_instance !< instance of damage kinematics mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - kinematics_hydrogen_strain_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - kinematics_hydrogen_strain_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - kinematics_hydrogen_strain_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - kinematics_hydrogen_strain_coeff - - public :: & - kinematics_hydrogen_strain_init, & - kinematics_hydrogen_strain_initialStrain, & - kinematics_hydrogen_strain_LiAndItsTangent, & - kinematics_hydrogen_strain_ChemPotAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_hydrogen_strain_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - phase_kinematics, & - phase_Nkinematics, & - phase_Noutput, & - KINEMATICS_hydrogen_strain_label, & - KINEMATICS_hydrogen_strain_ID - use config, only: & - material_Nphase, & - MATERIAL_partPhase - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,kinematics - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_hydrogen_strain_LABEL//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(phase_kinematics == KINEMATICS_hydrogen_strain_ID),pInt) - if (maxNinstance == 0_pInt) return - - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - - allocate(kinematics_hydrogen_strain_offset(material_Nphase), source=0_pInt) - allocate(kinematics_hydrogen_strain_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - kinematics_hydrogen_strain_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_hydrogen_strain_ID) - do kinematics = 1, phase_Nkinematics(phase) - if (phase_kinematics(kinematics,phase) == kinematics_hydrogen_strain_ID) & - kinematics_hydrogen_strain_offset(phase) = kinematics - enddo - enddo - - allocate(kinematics_hydrogen_strain_sizePostResults(maxNinstance), source=0_pInt) - allocate(kinematics_hydrogen_strain_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(kinematics_hydrogen_strain_output(maxval(phase_Noutput),maxNinstance)) - kinematics_hydrogen_strain_output = '' - allocate(kinematics_hydrogen_strain_Noutput(maxNinstance), source=0_pInt) - allocate(kinematics_hydrogen_strain_coeff(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_hydrogen_strain_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = kinematics_hydrogen_strain_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('hydrogen_strain_coeff') - kinematics_hydrogen_strain_coeff(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - -end subroutine kinematics_hydrogen_strain_init - -!-------------------------------------------------------------------------------------------------- -!> @brief report initial hydrogen strain based on current hydrogen conc deviation from -!> equillibrium (0) -!-------------------------------------------------------------------------------------------------- -pure function kinematics_hydrogen_strain_initialStrain(ipc, ip, el) - use math, only: & - math_I3 - use material, only: & - material_phase, & - material_homog, & - hydrogenConc, & - hydrogenfluxMapping - use lattice, only: & - lattice_equilibriumHydrogenConcentration - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), dimension(3,3) :: & - kinematics_hydrogen_strain_initialStrain !< initial thermal strain (should be small strain, though) - integer(pInt) :: & - phase, & - homog, offset, instance - - phase = material_phase(ipc,ip,el) - instance = kinematics_hydrogen_strain_instance(phase) - homog = material_homog(ip,el) - offset = hydrogenfluxMapping(homog)%p(ip,el) - - kinematics_hydrogen_strain_initialStrain = & - (hydrogenConc(homog)%p(offset) - lattice_equilibriumHydrogenConcentration(phase)) * & - kinematics_hydrogen_strain_coeff(instance)* math_I3 - -end function kinematics_hydrogen_strain_initialStrain - -!-------------------------------------------------------------------------------------------------- -!> @brief contains the constitutive equation for calculating the velocity gradient -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_hydrogen_strain_LiAndItsTangent(Li, dLi_dTstar3333, ipc, ip, el) - use material, only: & - material_phase, & - material_homog, & - hydrogenConc, & - hydrogenConcRate, & - hydrogenfluxMapping - use math, only: & - math_I3 - use lattice, only: & - lattice_equilibriumHydrogenConcentration - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(out), dimension(3,3) :: & - Li !< thermal velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & - dLi_dTstar3333 !< derivative of Li with respect to Tstar (4th-order tensor) - integer(pInt) :: & - phase, & - instance, & - homog, offset - real(pReal) :: & - Ch, ChEq, ChDot - - phase = material_phase(ipc,ip,el) - instance = kinematics_hydrogen_strain_instance(phase) - homog = material_homog(ip,el) - offset = hydrogenfluxMapping(homog)%p(ip,el) - Ch = hydrogenConc(homog)%p(offset) - ChDot = hydrogenConcRate(homog)%p(offset) - ChEq = lattice_equilibriumHydrogenConcentration(phase) - - Li = ChDot*math_I3* & - kinematics_hydrogen_strain_coeff(instance)/ & - (1.0_pReal + kinematics_hydrogen_strain_coeff(instance)*(Ch - ChEq)) - dLi_dTstar3333 = 0.0_pReal - -end subroutine kinematics_hydrogen_strain_LiAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief contains the kinematic contribution to hydrogen chemical potential -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_hydrogen_strain_ChemPotAndItsTangent(ChemPot, dChemPot_dCh, Tstar_v, Fi0, Fi, ipc, ip, el) - use material, only: & - material_phase - use math, only: & - math_inv33, & - math_mul33x33, & - math_Mandel6to33, & - math_transpose33 - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(in), dimension(6) :: & - Tstar_v - real(pReal), intent(in), dimension(3,3) :: & - Fi0, Fi - real(pReal), intent(out) :: & - ChemPot, dChemPot_dCh - integer(pInt) :: & - phase, & - instance - - phase = material_phase(ipc,ip,el) - instance = kinematics_hydrogen_strain_instance(phase) - - ChemPot = -kinematics_hydrogen_strain_coeff(instance)* & - sum(math_mul33x33(Fi,math_Mandel6to33(Tstar_v))* & - math_mul33x33(math_mul33x33(Fi,math_inv33(Fi0)),Fi)) - dChemPot_dCh = 0.0_pReal - -end subroutine kinematics_hydrogen_strain_ChemPotAndItsTangent - -end module kinematics_hydrogen_strain diff --git a/src/kinematics_vacancy_strain.f90 b/src/kinematics_vacancy_strain.f90 deleted file mode 100644 index 7ecc7fe6e..000000000 --- a/src/kinematics_vacancy_strain.f90 +++ /dev/null @@ -1,264 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine incorporating kinematics resulting from vacancy point defects -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module kinematics_vacancy_strain - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - kinematics_vacancy_strain_sizePostResults, & !< cumulative size of post results - kinematics_vacancy_strain_offset, & !< which kinematics is my current damage mechanism? - kinematics_vacancy_strain_instance !< instance of damage kinematics mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - kinematics_vacancy_strain_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - kinematics_vacancy_strain_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - kinematics_vacancy_strain_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - kinematics_vacancy_strain_coeff - - public :: & - kinematics_vacancy_strain_init, & - kinematics_vacancy_strain_initialStrain, & - kinematics_vacancy_strain_LiAndItsTangent, & - kinematics_vacancy_strain_ChemPotAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_vacancy_strain_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - phase_kinematics, & - phase_Nkinematics, & - phase_Noutput, & - KINEMATICS_vacancy_strain_label, & - KINEMATICS_vacancy_strain_ID - use config, only: & - material_Nphase, & - MATERIAL_partPhase - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,kinematics - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_vacancy_strain_LABEL//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(phase_kinematics == KINEMATICS_vacancy_strain_ID),pInt) - if (maxNinstance == 0_pInt) return - - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - - allocate(kinematics_vacancy_strain_offset(material_Nphase), source=0_pInt) - allocate(kinematics_vacancy_strain_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - kinematics_vacancy_strain_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_vacancy_strain_ID) - do kinematics = 1, phase_Nkinematics(phase) - if (phase_kinematics(kinematics,phase) == kinematics_vacancy_strain_ID) & - kinematics_vacancy_strain_offset(phase) = kinematics - enddo - enddo - - allocate(kinematics_vacancy_strain_sizePostResults(maxNinstance), source=0_pInt) - allocate(kinematics_vacancy_strain_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(kinematics_vacancy_strain_output(maxval(phase_Noutput),maxNinstance)) - kinematics_vacancy_strain_output = '' - allocate(kinematics_vacancy_strain_Noutput(maxNinstance), source=0_pInt) - allocate(kinematics_vacancy_strain_coeff(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_vacancy_strain_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = kinematics_vacancy_strain_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('vacancy_strain_coeff') - kinematics_vacancy_strain_coeff(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - -end subroutine kinematics_vacancy_strain_init - -!-------------------------------------------------------------------------------------------------- -!> @brief report initial vacancy strain based on current vacancy conc deviation from equillibrium -!-------------------------------------------------------------------------------------------------- -pure function kinematics_vacancy_strain_initialStrain(ipc, ip, el) - use math, only: & - math_I3 - use material, only: & - material_phase, & - material_homog, & - vacancyConc, & - vacancyfluxMapping - use lattice, only: & - lattice_equilibriumVacancyConcentration - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), dimension(3,3) :: & - kinematics_vacancy_strain_initialStrain !< initial thermal strain (should be small strain, though) - integer(pInt) :: & - phase, & - homog, offset, instance - - phase = material_phase(ipc,ip,el) - instance = kinematics_vacancy_strain_instance(phase) - homog = material_homog(ip,el) - offset = vacancyfluxMapping(homog)%p(ip,el) - - kinematics_vacancy_strain_initialStrain = & - (vacancyConc(homog)%p(offset) - lattice_equilibriumVacancyConcentration(phase)) * & - kinematics_vacancy_strain_coeff(instance)* math_I3 - -end function kinematics_vacancy_strain_initialStrain - -!-------------------------------------------------------------------------------------------------- -!> @brief contains the constitutive equation for calculating the velocity gradient -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_vacancy_strain_LiAndItsTangent(Li, dLi_dTstar3333, ipc, ip, el) - use material, only: & - material_phase, & - material_homog, & - vacancyConc, & - vacancyConcRate, & - vacancyfluxMapping - use math, only: & - math_I3 - use lattice, only: & - lattice_equilibriumVacancyConcentration - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(out), dimension(3,3) :: & - Li !< thermal velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & - dLi_dTstar3333 !< derivative of Li with respect to Tstar (4th-order tensor) - integer(pInt) :: & - phase, & - instance, & - homog, offset - real(pReal) :: & - Cv, CvEq, CvDot - - phase = material_phase(ipc,ip,el) - instance = kinematics_vacancy_strain_instance(phase) - homog = material_homog(ip,el) - offset = vacancyfluxMapping(homog)%p(ip,el) - - Cv = vacancyConc(homog)%p(offset) - CvDot = vacancyConcRate(homog)%p(offset) - CvEq = lattice_equilibriumvacancyConcentration(phase) - - Li = CvDot*math_I3* & - kinematics_vacancy_strain_coeff(instance)/ & - (1.0_pReal + kinematics_vacancy_strain_coeff(instance)*(Cv - CvEq)) - - dLi_dTstar3333 = 0.0_pReal - -end subroutine kinematics_vacancy_strain_LiAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief contains the kinematic contribution to vacancy chemical potential -!-------------------------------------------------------------------------------------------------- -subroutine kinematics_vacancy_strain_ChemPotAndItsTangent(ChemPot, dChemPot_dCv, Tstar_v, Fi0, Fi, ipc, ip, el) - use material, only: & - material_phase - use math, only: & - math_inv33, & - math_mul33x33, & - math_Mandel6to33, & - math_transpose33 - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(in), dimension(6) :: & - Tstar_v - real(pReal), intent(in), dimension(3,3) :: & - Fi0, Fi - real(pReal), intent(out) :: & - ChemPot, dChemPot_dCv - integer(pInt) :: & - phase, & - instance - - phase = material_phase(ipc,ip,el) - instance = kinematics_vacancy_strain_instance(phase) - - ChemPot = -kinematics_vacancy_strain_coeff(instance)* & - sum(math_mul33x33(Fi,math_Mandel6to33(Tstar_v))* & - math_mul33x33(math_mul33x33(Fi,math_inv33(Fi0)),Fi)) - dChemPot_dCv = 0.0_pReal - -end subroutine kinematics_vacancy_strain_ChemPotAndItsTangent - -end module kinematics_vacancy_strain diff --git a/src/material.f90 b/src/material.f90 index e52312c51..8356f43c7 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -40,15 +40,12 @@ module material KINEMATICS_cleavage_opening_label = 'cleavage_opening', & KINEMATICS_slipplane_opening_label = 'slipplane_opening', & STIFFNESS_DEGRADATION_damage_label = 'damage', & - STIFFNESS_DEGRADATION_porosity_label = 'porosity', & THERMAL_isothermal_label = 'isothermal', & THERMAL_adiabatic_label = 'adiabatic', & THERMAL_conduction_label = 'conduction', & DAMAGE_none_label = 'none', & DAMAGE_local_label = 'local', & DAMAGE_nonlocal_label = 'nonlocal', & - POROSITY_none_label = 'none', & - POROSITY_phasefield_label = 'phasefield', & HOMOGENIZATION_none_label = 'none', & HOMOGENIZATION_isostrain_label = 'isostrain', & HOMOGENIZATION_rgc_label = 'rgc' @@ -89,8 +86,7 @@ module material enum, bind(c) enumerator :: STIFFNESS_DEGRADATION_undefined_ID, & - STIFFNESS_DEGRADATION_damage_ID, & - STIFFNESS_DEGRADATION_porosity_ID + STIFFNESS_DEGRADATION_damage_ID end enum enum, bind(c) @@ -105,12 +101,6 @@ module material DAMAGE_nonlocal_ID end enum - enum, bind(c) - enumerator :: POROSITY_none_ID, & - POROSITY_phasefield_ID - end enum - - enum, bind(c) enumerator :: HOMOGENIZATION_undefined_ID, & HOMOGENIZATION_none_ID, & @@ -126,8 +116,6 @@ module material thermal_type !< thermal transport model integer(kind(DAMAGE_none_ID)), dimension(:), allocatable, public, protected :: & damage_type !< nonlocal damage model - integer(kind(POROSITY_none_ID)), dimension(:), allocatable, public, protected :: & - porosity_type !< porosity evolution model integer(kind(SOURCE_undefined_ID)), dimension(:,:), allocatable, public, protected :: & phase_source, & !< active sources mechanisms of each phase @@ -153,13 +141,11 @@ module material homogenization_typeInstance, & !< instance of particular type of each homogenization thermal_typeInstance, & !< instance of particular type of each thermal transport damage_typeInstance, & !< instance of particular type of each nonlocal damage - porosity_typeInstance, & !< instance of particular type of each porosity model microstructure_crystallite !< crystallite setting ID of each microstructure ! DEPRECATED !!!! real(pReal), dimension(:), allocatable, public, protected :: & thermal_initialT, & !< initial temperature per each homogenization - damage_initialPhi, & !< initial damage per each homogenization - porosity_initialPhi !< initial posority per each homogenization + damage_initialPhi !< initial damage per each homogenization ! NEW MAPPINGS integer(pInt), dimension(:), allocatable, public, protected :: & @@ -189,8 +175,7 @@ module material type(tState), allocatable, dimension(:), public :: & homogState, & thermalState, & - damageState, & - porosityState + damageState integer(pInt), dimension(:,:,:), allocatable, public, protected :: & material_texture !< texture (index) of each grain,IP,element @@ -240,13 +225,11 @@ module material type(tHomogMapping), allocatable, dimension(:), public :: & thermalMapping, & !< mapping for thermal state/fields - damageMapping, & !< mapping for damage state/fields - porosityMapping !< mapping for porosity state/fields + damageMapping !< mapping for damage state/fields type(group_float), allocatable, dimension(:), public :: & temperature, & !< temperature field damage, & !< damage field - porosity, & !< porosity field temperatureRate !< temperature change rate field public :: & @@ -270,15 +253,12 @@ module material KINEMATICS_slipplane_opening_ID, & KINEMATICS_thermal_expansion_ID, & STIFFNESS_DEGRADATION_damage_ID, & - STIFFNESS_DEGRADATION_porosity_ID, & THERMAL_isothermal_ID, & THERMAL_adiabatic_ID, & THERMAL_conduction_ID, & DAMAGE_none_ID, & DAMAGE_local_ID, & DAMAGE_nonlocal_ID, & - POROSITY_none_ID, & - POROSITY_phasefield_ID, & HOMOGENIZATION_none_ID, & HOMOGENIZATION_isostrain_ID, & HOMOGENIZATION_RGC_ID @@ -370,15 +350,12 @@ subroutine material_init() allocate(homogState (size(config_homogenization))) allocate(thermalState (size(config_homogenization))) allocate(damageState (size(config_homogenization))) - allocate(porosityState (size(config_homogenization))) allocate(thermalMapping (size(config_homogenization))) allocate(damageMapping (size(config_homogenization))) - allocate(porosityMapping (size(config_homogenization))) allocate(temperature (size(config_homogenization))) allocate(damage (size(config_homogenization))) - allocate(porosity (size(config_homogenization))) allocate(temperatureRate (size(config_homogenization))) @@ -453,10 +430,8 @@ subroutine material_init() do myHomog = 1,size(config_homogenization) thermalMapping (myHomog)%p => mappingHomogenizationConst damageMapping (myHomog)%p => mappingHomogenizationConst - porosityMapping (myHomog)%p => mappingHomogenizationConst allocate(temperature (myHomog)%p(1), source=thermal_initialT(myHomog)) allocate(damage (myHomog)%p(1), source=damage_initialPhi(myHomog)) - allocate(porosity (myHomog)%p(1), source=porosity_initialPhi(myHomog)) allocate(temperatureRate (myHomog)%p(1), source=0.0_pReal) enddo @@ -481,17 +456,14 @@ subroutine material_parseHomogenization allocate(homogenization_type(size(config_homogenization)), source=HOMOGENIZATION_undefined_ID) allocate(thermal_type(size(config_homogenization)), source=THERMAL_isothermal_ID) allocate(damage_type (size(config_homogenization)), source=DAMAGE_none_ID) - allocate(porosity_type (size(config_homogenization)), source=POROSITY_none_ID) allocate(homogenization_typeInstance(size(config_homogenization)), source=0_pInt) allocate(thermal_typeInstance(size(config_homogenization)), source=0_pInt) allocate(damage_typeInstance(size(config_homogenization)), source=0_pInt) - allocate(porosity_typeInstance(size(config_homogenization)), source=0_pInt) allocate(homogenization_Ngrains(size(config_homogenization)), source=0_pInt) allocate(homogenization_Noutput(size(config_homogenization)), source=0_pInt) allocate(homogenization_active(size(config_homogenization)), source=.false.) !!!!!!!!!!!!!!! allocate(thermal_initialT(size(config_homogenization)), source=300.0_pReal) allocate(damage_initialPhi(size(config_homogenization)), source=1.0_pReal) - allocate(porosity_initialPhi(size(config_homogenization)), source=1.0_pReal) forall (h = 1_pInt:size(config_homogenization)) & homogenization_active(h) = any(mesh_homogenizationAt == h) @@ -550,25 +522,6 @@ subroutine material_parseHomogenization end select endif - - - - if (config_homogenization(h)%keyExists('porosity')) then - !ToDo? - - tag = config_homogenization(h)%getString('porosity') - select case (trim(tag)) - case(POROSITY_NONE_label) - porosity_type(h) = POROSITY_none_ID - case(POROSITY_phasefield_label) - porosity_type(h) = POROSITY_phasefield_ID - case default - call IO_error(500_pInt,ext_msg=trim(tag)) - end select - - endif - - enddo @@ -576,7 +529,6 @@ subroutine material_parseHomogenization homogenization_typeInstance(h) = count(homogenization_type(1:h) == homogenization_type(h)) thermal_typeInstance(h) = count(thermal_type (1:h) == thermal_type (h)) damage_typeInstance(h) = count(damage_type (1:h) == damage_type (h)) - porosity_typeInstance(h) = count(porosity_type (1:h) == porosity_type (h)) enddo homogenization_maxNgrains = maxval(homogenization_Ngrains,homogenization_active) @@ -797,8 +749,6 @@ subroutine material_parsePhase select case (trim(str(stiffDegradationCtr))) case (STIFFNESS_DEGRADATION_damage_label) phase_stiffnessDegradation(stiffDegradationCtr,p) = STIFFNESS_DEGRADATION_damage_ID - case (STIFFNESS_DEGRADATION_porosity_label) - phase_stiffnessDegradation(stiffDegradationCtr,p) = STIFFNESS_DEGRADATION_porosity_ID end select enddo enddo diff --git a/src/porosity_none.f90 b/src/porosity_none.f90 deleted file mode 100644 index d8175cd9e..000000000 --- a/src/porosity_none.f90 +++ /dev/null @@ -1,60 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for constant porosity -!-------------------------------------------------------------------------------------------------- -module porosity_none - - implicit none - private - - public :: & - porosity_none_init - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all neccessary fields, reads information from material configuration file -!-------------------------------------------------------------------------------------------------- -subroutine porosity_none_init() -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use prec, only: & - pReal, & - pInt - use IO, only: & - IO_timeStamp - use material - use config - - implicit none - integer(pInt) :: & - homog, & - NofMyHomog - - write(6,'(/,a)') ' <<<+- porosity_'//POROSITY_none_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - initializeInstances: do homog = 1_pInt, material_Nhomogenization - - myhomog: if (porosity_type(homog) == POROSITY_none_ID) then - NofMyHomog = count(material_homog == homog) - porosityState(homog)%sizeState = 0_pInt - porosityState(homog)%sizePostResults = 0_pInt - allocate(porosityState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) - allocate(porosityState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) - allocate(porosityState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) - - deallocate(porosity(homog)%p) - allocate (porosity(homog)%p(1), source=porosity_initialPhi(homog)) - - endif myhomog - enddo initializeInstances - - -end subroutine porosity_none_init - -end module porosity_none diff --git a/src/porosity_phasefield.f90 b/src/porosity_phasefield.f90 deleted file mode 100644 index 1975ba64c..000000000 --- a/src/porosity_phasefield.f90 +++ /dev/null @@ -1,448 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for phase field modelling of pore nucleation and growth -!> @details phase field model for pore nucleation and growth based on vacancy clustering -!-------------------------------------------------------------------------------------------------- -module porosity_phasefield - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - porosity_phasefield_sizePostResults !< cumulative size of post results - - integer(pInt), dimension(:,:), allocatable, target, public :: & - porosity_phasefield_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - porosity_phasefield_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - porosity_phasefield_Noutput !< number of outputs per instance of this porosity - - enum, bind(c) - enumerator :: undefined_ID, & - porosity_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - porosity_phasefield_outputID !< ID of each post result output - - - public :: & - porosity_phasefield_init, & - porosity_phasefield_getFormationEnergy, & - porosity_phasefield_getSurfaceEnergy, & - porosity_phasefield_getSourceAndItsTangent, & - porosity_phasefield_getDiffusion33, & - porosity_phasefield_getMobility, & - porosity_phasefield_putPorosity, & - porosity_phasefield_postResults - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine porosity_phasefield_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - porosity_type, & - porosity_typeInstance, & - homogenization_Noutput, & - POROSITY_phasefield_label, & - POROSITY_phasefield_ID, & - material_homog, & - mappingHomogenization, & - porosityState, & - porosityMapping, & - porosity, & - porosity_initialPhi - use config, only: & - material_partHomogenization, & - material_partPhase - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- porosity_'//POROSITY_phasefield_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(porosity_type == POROSITY_phasefield_ID),pInt) - if (maxNinstance == 0_pInt) return - - allocate(porosity_phasefield_sizePostResults(maxNinstance), source=0_pInt) - allocate(porosity_phasefield_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(porosity_phasefield_output (maxval(homogenization_Noutput),maxNinstance)) - porosity_phasefield_output = '' - allocate(porosity_phasefield_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(porosity_phasefield_Noutput (maxNinstance), source=0_pInt) - - rewind(fileUnit) - section = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to - line = IO_read(fileUnit) - enddo - - parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next homog section - section = section + 1_pInt ! advance homog section counter - cycle ! skip to next line - endif - - if (section > 0_pInt ) then; if (porosity_type(section) == POROSITY_phasefield_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = porosity_typeInstance(section) ! which instance of my porosity is present homog - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('porosity') - porosity_phasefield_Noutput(instance) = porosity_phasefield_Noutput(instance) + 1_pInt - porosity_phasefield_outputID(porosity_phasefield_Noutput(instance),instance) = porosity_ID - porosity_phasefield_output(porosity_phasefield_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select - - end select - endif; endif - enddo parsingHomog - - initializeInstances: do section = 1_pInt, size(porosity_type) - if (porosity_type(section) == POROSITY_phasefield_ID) then - NofMyHomog=count(material_homog==section) - instance = porosity_typeInstance(section) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,porosity_phasefield_Noutput(instance) - select case(porosity_phasefield_outputID(o,instance)) - case(porosity_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - porosity_phasefield_sizePostResult(o,instance) = mySize - porosity_phasefield_sizePostResults(instance) = porosity_phasefield_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -! allocate state arrays - sizeState = 0_pInt - porosityState(section)%sizeState = sizeState - porosityState(section)%sizePostResults = porosity_phasefield_sizePostResults(instance) - allocate(porosityState(section)%state0 (sizeState,NofMyHomog)) - allocate(porosityState(section)%subState0(sizeState,NofMyHomog)) - allocate(porosityState(section)%state (sizeState,NofMyHomog)) - - nullify(porosityMapping(section)%p) - porosityMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(porosity(section)%p) - allocate(porosity(section)%p(NofMyHomog), source=porosity_initialPhi(section)) - - endif - - enddo initializeInstances -end subroutine porosity_phasefield_init - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized vacancy formation energy -!-------------------------------------------------------------------------------------------------- -function porosity_phasefield_getFormationEnergy(ip,el) - use lattice, only: & - lattice_vacancyFormationEnergy, & - lattice_vacancyVol - 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) :: & - porosity_phasefield_getFormationEnergy - integer(pInt) :: & - grain - - porosity_phasefield_getFormationEnergy = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - porosity_phasefield_getFormationEnergy = porosity_phasefield_getFormationEnergy + & - lattice_vacancyFormationEnergy(material_phase(grain,ip,el))/ & - lattice_vacancyVol(material_phase(grain,ip,el)) - enddo - - porosity_phasefield_getFormationEnergy = & - porosity_phasefield_getFormationEnergy/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function porosity_phasefield_getFormationEnergy - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized pore surface energy (normalized by characteristic length) -!-------------------------------------------------------------------------------------------------- -function porosity_phasefield_getSurfaceEnergy(ip,el) - use lattice, only: & - lattice_vacancySurfaceEnergy - 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) :: & - porosity_phasefield_getSurfaceEnergy - integer(pInt) :: & - grain - - porosity_phasefield_getSurfaceEnergy = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - porosity_phasefield_getSurfaceEnergy = porosity_phasefield_getSurfaceEnergy + & - lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) - enddo - - porosity_phasefield_getSurfaceEnergy = & - porosity_phasefield_getSurfaceEnergy/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function porosity_phasefield_getSurfaceEnergy - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates homogenized local driving force for pore nucleation and growth -!-------------------------------------------------------------------------------------------------- -subroutine porosity_phasefield_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el) - use math, only : & - math_mul33x33, & - math_mul66x6, & - math_Mandel33to6, & - math_transpose33, & - math_I3 - use material, only: & - homogenization_Ngrains, & - material_homog, & - material_phase, & - phase_NstiffnessDegradations, & - phase_stiffnessDegradation, & - vacancyConc, & - vacancyfluxMapping, & - damage, & - damageMapping, & - STIFFNESS_DEGRADATION_damage_ID - use crystallite, only: & - crystallite_Fe - use constitutive, only: & - constitutive_homogenizedC - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - phi - integer(pInt) :: & - phase, & - grain, & - homog, & - mech - real(pReal) :: & - phiDot, dPhiDot_dPhi, Cv, W_e, strain(6), C(6,6) - - homog = material_homog(ip,el) - Cv = vacancyConc(homog)%p(vacancyfluxMapping(homog)%p(ip,el)) - - W_e = 0.0_pReal - do grain = 1, homogenization_Ngrains(homog) - phase = material_phase(grain,ip,el) - strain = math_Mandel33to6(math_mul33x33(math_transpose33(crystallite_Fe(1:3,1:3,grain,ip,el)), & - crystallite_Fe(1:3,1:3,grain,ip,el)) - math_I3)/2.0_pReal - C = constitutive_homogenizedC(grain,ip,el) - do mech = 1_pInt, phase_NstiffnessDegradations(phase) - select case(phase_stiffnessDegradation(mech,phase)) - case (STIFFNESS_DEGRADATION_damage_ID) - C = damage(homog)%p(damageMapping(homog)%p(ip,el))* & - damage(homog)%p(damageMapping(homog)%p(ip,el))* & - C - - end select - enddo - W_e = W_e + sum(abs(strain*math_mul66x6(C,strain))) - enddo - W_e = W_e/real(homogenization_Ngrains(homog),pReal) - - phiDot = 2.0_pReal*(1.0_pReal - phi)*(1.0_pReal - Cv)*(1.0_pReal - Cv) - & - 2.0_pReal*phi*(W_e + Cv*porosity_phasefield_getFormationEnergy(ip,el))/ & - porosity_phasefield_getSurfaceEnergy (ip,el) - dPhiDot_dPhi = - 2.0_pReal*(1.0_pReal - Cv)*(1.0_pReal - Cv) & - - 2.0_pReal*(W_e + Cv*porosity_phasefield_getFormationEnergy(ip,el))/ & - porosity_phasefield_getSurfaceEnergy (ip,el) - -end subroutine porosity_phasefield_getSourceAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized nonlocal diffusion tensor in reference configuration -!-------------------------------------------------------------------------------------------------- -function porosity_phasefield_getDiffusion33(ip,el) - use lattice, only: & - lattice_PorosityDiffusion33 - use material, only: & - homogenization_Ngrains, & - material_phase, & - mappingHomogenization - use crystallite, only: & - crystallite_push33ToRef - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), dimension(3,3) :: & - porosity_phasefield_getDiffusion33 - integer(pInt) :: & - homog, & - grain - - homog = mappingHomogenization(2,ip,el) - porosity_phasefield_getDiffusion33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(homog) - porosity_phasefield_getDiffusion33 = porosity_phasefield_getDiffusion33 + & - crystallite_push33ToRef(grain,ip,el,lattice_PorosityDiffusion33(1:3,1:3,material_phase(grain,ip,el))) - enddo - - porosity_phasefield_getDiffusion33 = & - porosity_phasefield_getDiffusion33/real(homogenization_Ngrains(homog),pReal) - -end function porosity_phasefield_getDiffusion33 - -!-------------------------------------------------------------------------------------------------- -!> @brief Returns homogenized phase field mobility -!-------------------------------------------------------------------------------------------------- -real(pReal) function porosity_phasefield_getMobility(ip,el) - use mesh, only: & - mesh_element - use lattice, only: & - lattice_PorosityMobility - use material, only: & - material_phase, & - homogenization_Ngrains - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - integer(pInt) :: & - ipc - - porosity_phasefield_getMobility = 0.0_pReal - - do ipc = 1, homogenization_Ngrains(mesh_element(3,el)) - porosity_phasefield_getMobility = porosity_phasefield_getMobility & - + lattice_PorosityMobility(material_phase(ipc,ip,el)) - enddo - - porosity_phasefield_getMobility = & - porosity_phasefield_getMobility/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function porosity_phasefield_getMobility - -!-------------------------------------------------------------------------------------------------- -!> @brief updates porosity with solution from phasefield PDE -!-------------------------------------------------------------------------------------------------- -subroutine porosity_phasefield_putPorosity(phi,ip,el) - use material, only: & - material_homog, & - porosityMapping, & - porosity - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - phi - integer(pInt) :: & - homog, & - offset - - homog = material_homog(ip,el) - offset = porosityMapping(homog)%p(ip,el) - porosity(homog)%p(offset) = phi - -end subroutine porosity_phasefield_putPorosity - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of porosity results -!-------------------------------------------------------------------------------------------------- -function porosity_phasefield_postResults(ip,el) - use material, only: & - mappingHomogenization, & - porosity_typeInstance, & - porosity - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point - el !< element - real(pReal), dimension(porosity_phasefield_sizePostResults(porosity_typeInstance(mappingHomogenization(2,ip,el)))) :: & - porosity_phasefield_postResults - - integer(pInt) :: & - instance, homog, offset, o, c - - homog = mappingHomogenization(2,ip,el) - offset = mappingHomogenization(1,ip,el) - instance = porosity_typeInstance(homog) - - c = 0_pInt - porosity_phasefield_postResults = 0.0_pReal - - do o = 1_pInt,porosity_phasefield_Noutput(instance) - select case(porosity_phasefield_outputID(o,instance)) - - case (porosity_ID) - porosity_phasefield_postResults(c+1_pInt) = porosity(homog)%p(offset) - c = c + 1 - end select - enddo -end function porosity_phasefield_postResults - -end module porosity_phasefield diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 index fe964d134..5aa3648f3 100644 --- a/src/source_damage_isoBrittle.f90 +++ b/src/source_damage_isoBrittle.f90 @@ -246,10 +246,7 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) sourceState, & material_homog, & phase_NstiffnessDegradations, & - phase_stiffnessDegradation, & - porosity, & - porosityMapping, & - STIFFNESS_DEGRADATION_porosity_ID + phase_stiffnessDegradation use math, only : & math_mul33x33, & math_mul66x6, & diff --git a/src/source_vacancy_irradiation.f90 b/src/source_vacancy_irradiation.f90 deleted file mode 100644 index 67b4cabcf..000000000 --- a/src/source_vacancy_irradiation.f90 +++ /dev/null @@ -1,248 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for vacancy generation due to irradiation -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module source_vacancy_irradiation - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - source_vacancy_irradiation_sizePostResults, & !< cumulative size of post results - source_vacancy_irradiation_offset, & !< which source is my current damage mechanism? - source_vacancy_irradiation_instance !< instance of damage source mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - source_vacancy_irradiation_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - source_vacancy_irradiation_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - source_vacancy_irradiation_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - source_vacancy_irradiation_cascadeProb, & - source_vacancy_irradiation_cascadeVolume - - public :: & - source_vacancy_irradiation_init, & - source_vacancy_irradiation_deltaState, & - source_vacancy_irradiation_getRateAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_irradiation_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_vacancy_irradiation_label, & - SOURCE_vacancy_irradiation_ID, & - material_phase, & - sourceState - use config, only: & - material_Nphase, & - MATERIAL_partPhase - use numerics,only: & - numerics_integrator - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_irradiation_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(phase_source == SOURCE_vacancy_irradiation_ID),pInt) - if (maxNinstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - - allocate(source_vacancy_irradiation_offset(material_Nphase), source=0_pInt) - allocate(source_vacancy_irradiation_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - source_vacancy_irradiation_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_irradiation_ID) - do source = 1, phase_Nsources(phase) - if (phase_source(source,phase) == source_vacancy_irradiation_ID) & - source_vacancy_irradiation_offset(phase) = source - enddo - enddo - - allocate(source_vacancy_irradiation_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_vacancy_irradiation_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_vacancy_irradiation_output(maxval(phase_Noutput),maxNinstance)) - source_vacancy_irradiation_output = '' - allocate(source_vacancy_irradiation_Noutput(maxNinstance), source=0_pInt) - allocate(source_vacancy_irradiation_cascadeProb(maxNinstance), source=0.0_pReal) - allocate(source_vacancy_irradiation_cascadeVolume(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_irradiation_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = source_vacancy_irradiation_instance(phase) ! which instance of my vacancy is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('irradiation_cascadeprobability') - source_vacancy_irradiation_cascadeProb(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('irradiation_cascadevolume') - source_vacancy_irradiation_cascadeVolume(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_vacancy_irradiation_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_vacancy_irradiation_instance(phase) - sourceOffset = source_vacancy_irradiation_offset(phase) - - sizeDotState = 2_pInt - sizeDeltaState = 2_pInt - sizeState = 2_pInt - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_irradiation_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.1_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances -end subroutine source_vacancy_irradiation_init - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates derived quantities from state -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_irradiation_deltaState(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 - real(pReal) :: & - randNo - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - sourceOffset = source_vacancy_irradiation_offset(phase) - - call random_number(randNo) - sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & - randNo - sourceState(phase)%p(sourceOffset)%state(1,constituent) - call random_number(randNo) - sourceState(phase)%p(sourceOffset)%deltaState(2,constituent) = & - randNo - sourceState(phase)%p(sourceOffset)%state(2,constituent) - -end subroutine source_vacancy_irradiation_deltaState - -!-------------------------------------------------------------------------------------------------- -!> @brief returns local vacancy generation rate -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_irradiation_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) - use material, only: & - phaseAt, phasememberAt, & - sourceState - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(out) :: & - CvDot, dCvDot_dCv - integer(pInt) :: & - instance, phase, constituent, sourceOffset - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - instance = source_vacancy_irradiation_instance(phase) - sourceOffset = source_vacancy_irradiation_offset(phase) - - CvDot = 0.0_pReal - dCvDot_dCv = 0.0_pReal - if (sourceState(phase)%p(sourceOffset)%state0(1,constituent) < source_vacancy_irradiation_cascadeProb(instance)) & - CvDot = sourceState(phase)%p(sourceOffset)%state0(2,constituent)*source_vacancy_irradiation_cascadeVolume(instance) - -end subroutine source_vacancy_irradiation_getRateAndItsTangent - -end module source_vacancy_irradiation diff --git a/src/source_vacancy_phenoplasticity.f90 b/src/source_vacancy_phenoplasticity.f90 deleted file mode 100644 index e20d8ec06..000000000 --- a/src/source_vacancy_phenoplasticity.f90 +++ /dev/null @@ -1,210 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for vacancy generation due to plasticity -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module source_vacancy_phenoplasticity - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - source_vacancy_phenoplasticity_sizePostResults, & !< cumulative size of post results - source_vacancy_phenoplasticity_offset, & !< which source is my current damage mechanism? - source_vacancy_phenoplasticity_instance !< instance of damage source mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - source_vacancy_phenoplasticity_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - source_vacancy_phenoplasticity_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - source_vacancy_phenoplasticity_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - source_vacancy_phenoplasticity_rateCoeff - - public :: & - source_vacancy_phenoplasticity_init, & - source_vacancy_phenoplasticity_getRateAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_phenoplasticity_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_vacancy_phenoplasticity_label, & - SOURCE_vacancy_phenoplasticity_ID, & - material_phase, & - sourceState - use config, only: & - material_Nphase, & - MATERIAL_partPhase - use numerics,only: & - numerics_integrator - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_phenoplasticity_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(phase_source == SOURCE_vacancy_phenoplasticity_ID),pInt) - if (maxNinstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - - allocate(source_vacancy_phenoplasticity_offset(material_Nphase), source=0_pInt) - allocate(source_vacancy_phenoplasticity_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - source_vacancy_phenoplasticity_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_phenoplasticity_ID) - do source = 1, phase_Nsources(phase) - if (phase_source(source,phase) == source_vacancy_phenoplasticity_ID) & - source_vacancy_phenoplasticity_offset(phase) = source - enddo - enddo - - allocate(source_vacancy_phenoplasticity_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_vacancy_phenoplasticity_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_vacancy_phenoplasticity_output(maxval(phase_Noutput),maxNinstance)) - source_vacancy_phenoplasticity_output = '' - allocate(source_vacancy_phenoplasticity_Noutput(maxNinstance), source=0_pInt) - allocate(source_vacancy_phenoplasticity_rateCoeff(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_phenoplasticity_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = source_vacancy_phenoplasticity_instance(phase) ! which instance of my vacancy is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('phenoplasticity_ratecoeff') - source_vacancy_phenoplasticity_rateCoeff(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_vacancy_phenoplasticity_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_vacancy_phenoplasticity_instance(phase) - sourceOffset = source_vacancy_phenoplasticity_offset(phase) - - sizeDotState = 0_pInt - sizeDeltaState = 0_pInt - sizeState = 0_pInt - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_phenoplasticity_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances -end subroutine source_vacancy_phenoplasticity_init - -!-------------------------------------------------------------------------------------------------- -!> @brief returns local vacancy generation rate -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_phenoplasticity_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) - use material, only: & - phaseAt, phasememberAt, & - plasticState - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(out) :: & - CvDot, dCvDot_dCv - integer(pInt) :: & - instance, phase, constituent - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - instance = source_vacancy_phenoplasticity_instance(phase) - - CvDot = & - source_vacancy_phenoplasticity_rateCoeff(instance)* & - sum(plasticState(phase)%slipRate(:,constituent)) - dCvDot_dCv = 0.0_pReal - -end subroutine source_vacancy_phenoplasticity_getRateAndItsTangent - -end module source_vacancy_phenoplasticity diff --git a/src/source_vacancy_thermalfluc.f90 b/src/source_vacancy_thermalfluc.f90 deleted file mode 100644 index cea52aa75..000000000 --- a/src/source_vacancy_thermalfluc.f90 +++ /dev/null @@ -1,250 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for vacancy generation due to thermal fluctuations -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module source_vacancy_thermalfluc - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - source_vacancy_thermalfluc_sizePostResults, & !< cumulative size of post results - source_vacancy_thermalfluc_offset, & !< which source is my current damage mechanism? - source_vacancy_thermalfluc_instance !< instance of damage source mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - source_vacancy_thermalfluc_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - source_vacancy_thermalfluc_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - source_vacancy_thermalfluc_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - source_vacancy_thermalfluc_amplitude, & - source_vacancy_thermalfluc_normVacancyEnergy - - public :: & - source_vacancy_thermalfluc_init, & - source_vacancy_thermalfluc_deltaState, & - source_vacancy_thermalfluc_getRateAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_thermalfluc_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use lattice, only: & - lattice_vacancyFormationEnergy - use material, only: & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_vacancy_thermalfluc_label, & - SOURCE_vacancy_thermalfluc_ID, & - material_phase, & - sourceState - use config, only: & - material_Nphase, & - MATERIAL_partPhase - use numerics,only: & - numerics_integrator - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_thermalfluc_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(phase_source == SOURCE_vacancy_thermalfluc_ID),pInt) - if (maxNinstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - - allocate(source_vacancy_thermalfluc_offset(material_Nphase), source=0_pInt) - allocate(source_vacancy_thermalfluc_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - source_vacancy_thermalfluc_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_thermalfluc_ID) - do source = 1, phase_Nsources(phase) - if (phase_source(source,phase) == source_vacancy_thermalfluc_ID) & - source_vacancy_thermalfluc_offset(phase) = source - enddo - enddo - - allocate(source_vacancy_thermalfluc_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_vacancy_thermalfluc_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_vacancy_thermalfluc_output(maxval(phase_Noutput),maxNinstance)) - source_vacancy_thermalfluc_output = '' - allocate(source_vacancy_thermalfluc_Noutput(maxNinstance), source=0_pInt) - allocate(source_vacancy_thermalfluc_amplitude(maxNinstance), source=0.0_pReal) - allocate(source_vacancy_thermalfluc_normVacancyEnergy(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_thermalfluc_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = source_vacancy_thermalfluc_instance(phase) ! which instance of my vacancy is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('thermalfluctuation_amplitude') - source_vacancy_thermalfluc_amplitude(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_vacancy_thermalfluc_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_vacancy_thermalfluc_instance(phase) - source_vacancy_thermalfluc_normVacancyEnergy(instance) = & - lattice_vacancyFormationEnergy(phase)/1.3806488e-23_pReal - sourceOffset = source_vacancy_thermalfluc_offset(phase) - - sizeDotState = 1_pInt - sizeDeltaState = 1_pInt - sizeState = 1_pInt - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_thermalfluc_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.1_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances -end subroutine source_vacancy_thermalfluc_init - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates derived quantities from state -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_thermalfluc_deltaState(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 - real(pReal) :: & - randNo - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - sourceOffset = source_vacancy_thermalfluc_offset(phase) - - call random_number(randNo) - sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & - randNo - 0.5_pReal - sourceState(phase)%p(sourceOffset)%state(1,constituent) - -end subroutine source_vacancy_thermalfluc_deltaState - -!-------------------------------------------------------------------------------------------------- -!> @brief returns local vacancy generation rate -!-------------------------------------------------------------------------------------------------- -subroutine source_vacancy_thermalfluc_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) - use material, only: & - phaseAt, phasememberAt, & - material_homog, & - temperature, & - thermalMapping, & - sourceState - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< grain number - ip, & !< integration point number - el !< element number - real(pReal), intent(out) :: & - CvDot, dCvDot_dCv - integer(pInt) :: & - instance, phase, constituent, sourceOffset - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - instance = source_vacancy_thermalfluc_instance(phase) - sourceOffset = source_vacancy_thermalfluc_offset(phase) - - CvDot = source_vacancy_thermalfluc_amplitude(instance)* & - sourceState(phase)%p(sourceOffset)%state0(2,constituent)* & - exp(-source_vacancy_thermalfluc_normVacancyEnergy(instance)/ & - temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))) - dCvDot_dCv = 0.0_pReal - -end subroutine source_vacancy_thermalfluc_getRateAndItsTangent - -end module source_vacancy_thermalfluc diff --git a/src/vacancyflux_cahnhilliard.f90 b/src/vacancyflux_cahnhilliard.f90 deleted file mode 100644 index ae5bd1cbc..000000000 --- a/src/vacancyflux_cahnhilliard.f90 +++ /dev/null @@ -1,602 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for conservative transport of vacancy concentration field -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module vacancyflux_cahnhilliard - use prec, only: & - pReal, & - pInt, & - group_float - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - vacancyflux_cahnhilliard_sizePostResults !< cumulative size of post results - - integer(pInt), dimension(:,:), allocatable, target, public :: & - vacancyflux_cahnhilliard_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - vacancyflux_cahnhilliard_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - vacancyflux_cahnhilliard_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - vacancyflux_cahnhilliard_flucAmplitude - - type(group_float), dimension(:), allocatable, private :: & - vacancyflux_cahnhilliard_thermalFluc - - real(pReal), parameter, private :: & - kB = 1.3806488e-23_pReal !< Boltzmann constant in J/Kelvin - - enum, bind(c) - enumerator :: undefined_ID, & - vacancyConc_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - vacancyflux_cahnhilliard_outputID !< ID of each post result output - - - public :: & - vacancyflux_cahnhilliard_init, & - vacancyflux_cahnhilliard_getSourceAndItsTangent, & - vacancyflux_cahnhilliard_getMobility33, & - vacancyflux_cahnhilliard_getDiffusion33, & - vacancyflux_cahnhilliard_getChemPotAndItsTangent, & - vacancyflux_cahnhilliard_putVacancyConcAndItsRate, & - vacancyflux_cahnhilliard_postResults - private :: & - vacancyflux_cahnhilliard_getFormationEnergy, & - vacancyflux_cahnhilliard_getEntropicCoeff, & - vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_cahnhilliard_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - vacancyflux_type, & - vacancyflux_typeInstance, & - homogenization_Noutput, & - VACANCYFLUX_cahnhilliard_label, & - VACANCYFLUX_cahnhilliard_ID, & - material_homog, & - mappingHomogenization, & - vacancyfluxState, & - vacancyfluxMapping, & - vacancyConc, & - vacancyConcRate, & - vacancyflux_initialCv - use config, only: & - material_partPhase, & - material_partHomogenization - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o,offset - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_cahnhilliard_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(vacancyflux_type == VACANCYFLUX_cahnhilliard_ID),pInt) - if (maxNinstance == 0_pInt) return - - allocate(vacancyflux_cahnhilliard_sizePostResults(maxNinstance), source=0_pInt) - allocate(vacancyflux_cahnhilliard_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(vacancyflux_cahnhilliard_output (maxval(homogenization_Noutput),maxNinstance)) - vacancyflux_cahnhilliard_output = '' - allocate(vacancyflux_cahnhilliard_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(vacancyflux_cahnhilliard_Noutput (maxNinstance), source=0_pInt) - - allocate(vacancyflux_cahnhilliard_flucAmplitude (maxNinstance)) - allocate(vacancyflux_cahnhilliard_thermalFluc (maxNinstance)) - - rewind(fileUnit) - section = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to - line = IO_read(fileUnit) - enddo - - parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next homog section - section = section + 1_pInt ! advance homog section counter - cycle ! skip to next line - endif - - if (section > 0_pInt ) then; if (vacancyflux_type(section) == VACANCYFLUX_cahnhilliard_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = vacancyflux_typeInstance(section) ! which instance of my vacancyflux is present homog - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('vacancyconc') - vacancyflux_cahnhilliard_Noutput(instance) = vacancyflux_cahnhilliard_Noutput(instance) + 1_pInt - vacancyflux_cahnhilliard_outputID(vacancyflux_cahnhilliard_Noutput(instance),instance) = vacancyConc_ID - vacancyflux_cahnhilliard_output(vacancyflux_cahnhilliard_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select - - case ('vacancyflux_flucamplitude') - vacancyflux_cahnhilliard_flucAmplitude(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingHomog - - initializeInstances: do section = 1_pInt, size(vacancyflux_type) - if (vacancyflux_type(section) == VACANCYFLUX_cahnhilliard_ID) then - NofMyHomog=count(material_homog==section) - instance = vacancyflux_typeInstance(section) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,vacancyflux_cahnhilliard_Noutput(instance) - select case(vacancyflux_cahnhilliard_outputID(o,instance)) - case(vacancyConc_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - vacancyflux_cahnhilliard_sizePostResult(o,instance) = mySize - vacancyflux_cahnhilliard_sizePostResults(instance) = vacancyflux_cahnhilliard_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -! allocate state arrays - sizeState = 0_pInt - vacancyfluxState(section)%sizeState = sizeState - vacancyfluxState(section)%sizePostResults = vacancyflux_cahnhilliard_sizePostResults(instance) - allocate(vacancyfluxState(section)%state0 (sizeState,NofMyHomog)) - allocate(vacancyfluxState(section)%subState0(sizeState,NofMyHomog)) - allocate(vacancyfluxState(section)%state (sizeState,NofMyHomog)) - - allocate(vacancyflux_cahnhilliard_thermalFluc(instance)%p(NofMyHomog)) - do offset = 1_pInt, NofMyHomog - call random_number(vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset)) - vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset) = & - 1.0_pReal - & - vacancyflux_cahnhilliard_flucAmplitude(instance)* & - (vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset) - 0.5_pReal) - enddo - - nullify(vacancyfluxMapping(section)%p) - vacancyfluxMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(vacancyConc (section)%p) - allocate (vacancyConc (section)%p(NofMyHomog), source=vacancyflux_initialCv(section)) - deallocate(vacancyConcRate(section)%p) - allocate (vacancyConcRate(section)%p(NofMyHomog), source=0.0_pReal) - - endif - - enddo initializeInstances - -end subroutine vacancyflux_cahnhilliard_init - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates homogenized vacancy driving forces -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_cahnhilliard_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) - use material, only: & - homogenization_Ngrains, & - mappingHomogenization, & - phaseAt, & - phase_source, & - phase_Nsources, & - SOURCE_vacancy_phenoplasticity_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID - use source_vacancy_phenoplasticity, only: & - source_vacancy_phenoplasticity_getRateAndItsTangent - use source_vacancy_irradiation, only: & - source_vacancy_irradiation_getRateAndItsTangent - use source_vacancy_thermalfluc, only: & - source_vacancy_thermalfluc_getRateAndItsTangent - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Cv - integer(pInt) :: & - phase, & - grain, & - source - real(pReal) :: & - CvDot, dCvDot_dCv, localCvDot, dLocalCvDot_dCv - - CvDot = 0.0_pReal - dCvDot_dCv = 0.0_pReal - do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) - phase = phaseAt(grain,ip,el) - do source = 1_pInt, phase_Nsources(phase) - select case(phase_source(source,phase)) - case (SOURCE_vacancy_phenoplasticity_ID) - call source_vacancy_phenoplasticity_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) - - case (SOURCE_vacancy_irradiation_ID) - call source_vacancy_irradiation_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) - - case (SOURCE_vacancy_thermalfluc_ID) - call source_vacancy_thermalfluc_getRateAndItsTangent(localCvDot, dLocalCvDot_dCv, grain, ip, el) - - end select - CvDot = CvDot + localCvDot - dCvDot_dCv = dCvDot_dCv + dLocalCvDot_dCv - enddo - enddo - - CvDot = CvDot/real(homogenization_Ngrains(mappingHomogenization(2,ip,el)),pReal) - dCvDot_dCv = dCvDot_dCv/real(homogenization_Ngrains(mappingHomogenization(2,ip,el)),pReal) - -end subroutine vacancyflux_cahnhilliard_getSourceAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized vacancy mobility tensor in reference configuration -!-------------------------------------------------------------------------------------------------- -function vacancyflux_cahnhilliard_getMobility33(ip,el) - use lattice, only: & - lattice_vacancyfluxMobility33 - 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) :: & - vacancyflux_cahnhilliard_getMobility33 - integer(pInt) :: & - grain - - vacancyflux_cahnhilliard_getMobility33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - vacancyflux_cahnhilliard_getMobility33 = vacancyflux_cahnhilliard_getMobility33 + & - crystallite_push33ToRef(grain,ip,el,lattice_vacancyfluxMobility33(:,:,material_phase(grain,ip,el))) - enddo - - vacancyflux_cahnhilliard_getMobility33 = & - vacancyflux_cahnhilliard_getMobility33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function vacancyflux_cahnhilliard_getMobility33 - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized vacancy diffusion tensor in reference configuration -!-------------------------------------------------------------------------------------------------- -function vacancyflux_cahnhilliard_getDiffusion33(ip,el) - use lattice, only: & - lattice_vacancyfluxDiffusion33 - 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) :: & - vacancyflux_cahnhilliard_getDiffusion33 - integer(pInt) :: & - grain - - vacancyflux_cahnhilliard_getDiffusion33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - vacancyflux_cahnhilliard_getDiffusion33 = vacancyflux_cahnhilliard_getDiffusion33 + & - crystallite_push33ToRef(grain,ip,el,lattice_vacancyfluxDiffusion33(:,:,material_phase(grain,ip,el))) - enddo - - vacancyflux_cahnhilliard_getDiffusion33 = & - vacancyflux_cahnhilliard_getDiffusion33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function vacancyflux_cahnhilliard_getDiffusion33 - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized vacancy formation energy -!-------------------------------------------------------------------------------------------------- -real(pReal) function vacancyflux_cahnhilliard_getFormationEnergy(ip,el) - use lattice, only: & - lattice_vacancyFormationEnergy, & - lattice_vacancyVol, & - lattice_vacancySurfaceEnergy - 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 - integer(pInt) :: & - grain - - vacancyflux_cahnhilliard_getFormationEnergy = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - vacancyflux_cahnhilliard_getFormationEnergy = vacancyflux_cahnhilliard_getFormationEnergy + & - lattice_vacancyFormationEnergy(material_phase(grain,ip,el))/ & - lattice_vacancyVol(material_phase(grain,ip,el))/ & - lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) - enddo - - vacancyflux_cahnhilliard_getFormationEnergy = & - vacancyflux_cahnhilliard_getFormationEnergy/real(homogenization_Ngrains(mesh_element(3,el)),pReal) - -end function vacancyflux_cahnhilliard_getFormationEnergy - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized vacancy entropy coefficient -!-------------------------------------------------------------------------------------------------- -real(pReal) function vacancyflux_cahnhilliard_getEntropicCoeff(ip,el) - use lattice, only: & - lattice_vacancyVol, & - lattice_vacancySurfaceEnergy - use material, only: & - homogenization_Ngrains, & - material_homog, & - material_phase, & - temperature, & - thermalMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - integer(pInt) :: & - grain - - vacancyflux_cahnhilliard_getEntropicCoeff = 0.0_pReal - do grain = 1, homogenization_Ngrains(material_homog(ip,el)) - vacancyflux_cahnhilliard_getEntropicCoeff = vacancyflux_cahnhilliard_getEntropicCoeff + & - kB/ & - lattice_vacancyVol(material_phase(grain,ip,el))/ & - lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) - enddo - - vacancyflux_cahnhilliard_getEntropicCoeff = & - vacancyflux_cahnhilliard_getEntropicCoeff* & - temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))/ & - real(homogenization_Ngrains(material_homog(ip,el)),pReal) - -end function vacancyflux_cahnhilliard_getEntropicCoeff - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized kinematic contribution to chemical potential -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCv, Cv, ip, el) - use lattice, only: & - lattice_vacancySurfaceEnergy - use material, only: & - homogenization_Ngrains, & - material_homog, & - phase_kinematics, & - phase_Nkinematics, & - material_phase, & - KINEMATICS_vacancy_strain_ID - use crystallite, only: & - crystallite_Tstar_v, & - crystallite_Fi0, & - crystallite_Fi - use kinematics_vacancy_strain, only: & - kinematics_vacancy_strain_ChemPotAndItsTangent - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Cv - real(pReal), intent(out) :: & - KPot, dKPot_dCv - real(pReal) :: & - my_KPot, my_dKPot_dCv - integer(pInt) :: & - grain, kinematics - - KPot = 0.0_pReal - dKPot_dCv = 0.0_pReal - do grain = 1_pInt,homogenization_Ngrains(material_homog(ip,el)) - do kinematics = 1_pInt, phase_Nkinematics(material_phase(grain,ip,el)) - select case (phase_kinematics(kinematics,material_phase(grain,ip,el))) - case (KINEMATICS_vacancy_strain_ID) - call kinematics_vacancy_strain_ChemPotAndItsTangent(my_KPot, my_dKPot_dCv, & - crystallite_Tstar_v(1:6,grain,ip,el), & - crystallite_Fi0(1:3,1:3,grain,ip,el), & - crystallite_Fi (1:3,1:3,grain,ip,el), & - grain,ip, el) - - case default - my_KPot = 0.0_pReal - my_dKPot_dCv = 0.0_pReal - - end select - KPot = KPot + my_KPot/lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) - dKPot_dCv = dKPot_dCv + my_dKPot_dCv/lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) - enddo - enddo - - KPot = KPot/real(homogenization_Ngrains(material_homog(ip,el)),pReal) - dKPot_dCv = dKPot_dCv/real(homogenization_Ngrains(material_homog(ip,el)),pReal) - -end subroutine vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief returns homogenized chemical potential and its tangent -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_cahnhilliard_getChemPotAndItsTangent(ChemPot,dChemPot_dCv,Cv,ip,el) - use numerics, only: & - vacancyBoundPenalty, & - vacancyPolyOrder - use material, only: & - mappingHomogenization, & - vacancyflux_typeInstance, & - porosity, & - porosityMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Cv - real(pReal), intent(out) :: & - ChemPot, & - dChemPot_dCv - real(pReal) :: & - VoidPhaseFrac, kBT, KPot, dKPot_dCv - integer(pInt) :: & - homog, o - - homog = mappingHomogenization(2,ip,el) - VoidPhaseFrac = porosity(homog)%p(porosityMapping(homog)%p(ip,el)) - kBT = vacancyflux_cahnhilliard_getEntropicCoeff(ip,el) - - ChemPot = vacancyflux_cahnhilliard_getFormationEnergy(ip,el) - dChemPot_dCv = 0.0_pReal - do o = 1_pInt, vacancyPolyOrder - ChemPot = ChemPot + kBT*((2.0_pReal*Cv - 1.0_pReal)**real(2_pInt*o-1_pInt,pReal))/ & - real(2_pInt*o-1_pInt,pReal) - dChemPot_dCv = dChemPot_dCv + 2.0_pReal*kBT*(2.0_pReal*Cv - 1.0_pReal)**real(2_pInt*o-2_pInt,pReal) - enddo - - ChemPot = VoidPhaseFrac*VoidPhaseFrac*ChemPot & - - 2.0_pReal*(1.0_pReal - Cv)*(1.0_pReal - VoidPhaseFrac)*(1.0_pReal - VoidPhaseFrac) - - dChemPot_dCv = VoidPhaseFrac*VoidPhaseFrac*dChemPot_dCv & - + 2.0_pReal*(1.0_pReal - VoidPhaseFrac)*(1.0_pReal - VoidPhaseFrac) - - call vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCv, Cv, ip, el) - ChemPot = ChemPot + KPot - dChemPot_dCv = dChemPot_dCv + dKPot_dCv - - if (Cv < 0.0_pReal) then - ChemPot = ChemPot - 3.0_pReal*vacancyBoundPenalty*Cv*Cv - dChemPot_dCv = dChemPot_dCv - 6.0_pReal*vacancyBoundPenalty*Cv - elseif (Cv > 1.0_pReal) then - ChemPot = ChemPot + 3.0_pReal*vacancyBoundPenalty*(1.0_pReal - Cv)*(1.0_pReal - Cv) - dChemPot_dCv = dChemPot_dCv - 6.0_pReal*vacancyBoundPenalty*(1.0_pReal - Cv) - endif - - ChemPot = ChemPot* & - vacancyflux_cahnhilliard_thermalFluc(vacancyflux_typeInstance(homog))%p(mappingHomogenization(1,ip,el)) - dChemPot_dCv = dChemPot_dCv* & - vacancyflux_cahnhilliard_thermalFluc(vacancyflux_typeInstance(homog))%p(mappingHomogenization(1,ip,el)) - -end subroutine vacancyflux_cahnhilliard_getChemPotAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief updated vacancy concentration and its rate with solution from transport PDE -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_cahnhilliard_putVacancyConcAndItsRate(Cv,Cvdot,ip,el) - use material, only: & - mappingHomogenization, & - vacancyConc, & - vacancyConcRate, & - vacancyfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Cv, & - Cvdot - integer(pInt) :: & - homog, & - offset - - homog = mappingHomogenization(2,ip,el) - offset = vacancyfluxMapping(homog)%p(ip,el) - vacancyConc (homog)%p(offset) = Cv - vacancyConcRate(homog)%p(offset) = Cvdot - -end subroutine vacancyflux_cahnhilliard_putVacancyConcAndItsRate - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of vacancy transport results -!-------------------------------------------------------------------------------------------------- -function vacancyflux_cahnhilliard_postResults(ip,el) - use material, only: & - mappingHomogenization, & - vacancyflux_typeInstance, & - vacancyConc, & - vacancyfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point - el !< element - real(pReal), dimension(vacancyflux_cahnhilliard_sizePostResults(vacancyflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & - vacancyflux_cahnhilliard_postResults - - integer(pInt) :: & - instance, homog, offset, o, c - - homog = mappingHomogenization(2,ip,el) - offset = vacancyfluxMapping(homog)%p(ip,el) - instance = vacancyflux_typeInstance(homog) - - c = 0_pInt - vacancyflux_cahnhilliard_postResults = 0.0_pReal - - do o = 1_pInt,vacancyflux_cahnhilliard_Noutput(instance) - select case(vacancyflux_cahnhilliard_outputID(o,instance)) - - case (vacancyConc_ID) - vacancyflux_cahnhilliard_postResults(c+1_pInt) = vacancyConc(homog)%p(offset) - c = c + 1 - end select - enddo -end function vacancyflux_cahnhilliard_postResults - -end module vacancyflux_cahnhilliard diff --git a/src/vacancyflux_isochempot.f90 b/src/vacancyflux_isochempot.f90 deleted file mode 100644 index 761a0ba22..000000000 --- a/src/vacancyflux_isochempot.f90 +++ /dev/null @@ -1,328 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for locally evolving vacancy concentration -!> @details to be done -!-------------------------------------------------------------------------------------------------- -module vacancyflux_isochempot - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - vacancyflux_isochempot_sizePostResults !< cumulative size of post results - - integer(pInt), dimension(:,:), allocatable, target, public :: & - vacancyflux_isochempot_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - vacancyflux_isochempot_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - vacancyflux_isochempot_Noutput !< number of outputs per instance of this damage - - enum, bind(c) - enumerator :: undefined_ID, & - vacancyconc_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - vacancyflux_isochempot_outputID !< ID of each post result output - - - public :: & - vacancyflux_isochempot_init, & - vacancyflux_isochempot_updateState, & - vacancyflux_isochempot_getSourceAndItsTangent, & - vacancyflux_isochempot_postResults - -contains - - -!-------------------------------------------------------------------------------------------------- -!> @brief module initialization -!> @details reads in material parameters, allocates arrays, and does sanity checks -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_isochempot_init(fileUnit) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF - use material, only: & - vacancyflux_type, & - vacancyflux_typeInstance, & - homogenization_Noutput, & - VACANCYFLUX_isochempot_label, & - VACANCYFLUX_isochempot_ID, & - material_homog, & - mappingHomogenization, & - vacancyfluxState, & - vacancyfluxMapping, & - vacancyConc, & - vacancyConcRate, & - vacancyflux_initialCv - use config, only: & - material_partHomogenization - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536) :: & - tag = '', & - line = '' - - write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_isochempot_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - maxNinstance = int(count(vacancyflux_type == VACANCYFLUX_isochempot_ID),pInt) - if (maxNinstance == 0_pInt) return - - allocate(vacancyflux_isochempot_sizePostResults(maxNinstance), source=0_pInt) - allocate(vacancyflux_isochempot_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(vacancyflux_isochempot_output (maxval(homogenization_Noutput),maxNinstance)) - vacancyflux_isochempot_output = '' - allocate(vacancyflux_isochempot_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(vacancyflux_isochempot_Noutput (maxNinstance), source=0_pInt) - - rewind(fileUnit) - section = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next homog section - section = section + 1_pInt ! advance homog section counter - cycle ! skip to next line - endif - - if (section > 0_pInt ) then; if (vacancyflux_type(section) == VACANCYFLUX_isochempot_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - - instance = vacancyflux_typeInstance(section) ! which instance of my vacancyflux is present homog - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('vacancyconc') - vacancyflux_isochempot_Noutput(instance) = vacancyflux_isochempot_Noutput(instance) + 1_pInt - vacancyflux_isochempot_outputID(vacancyflux_isochempot_Noutput(instance),instance) = vacancyconc_ID - vacancyflux_isochempot_output(vacancyflux_isochempot_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select - - end select - endif; endif - enddo parsingFile - - initializeInstances: do section = 1_pInt, size(vacancyflux_type) - if (vacancyflux_type(section) == VACANCYFLUX_isochempot_ID) then - NofMyHomog=count(material_homog==section) - instance = vacancyflux_typeInstance(section) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,vacancyflux_isochempot_Noutput(instance) - select case(vacancyflux_isochempot_outputID(o,instance)) - case(vacancyconc_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - vacancyflux_isochempot_sizePostResult(o,instance) = mySize - vacancyflux_isochempot_sizePostResults(instance) = vacancyflux_isochempot_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -! allocate state arrays - sizeState = 1_pInt - vacancyfluxState(section)%sizeState = sizeState - vacancyfluxState(section)%sizePostResults = vacancyflux_isochempot_sizePostResults(instance) - allocate(vacancyfluxState(section)%state0 (sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) - allocate(vacancyfluxState(section)%subState0(sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) - allocate(vacancyfluxState(section)%state (sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) - - nullify(vacancyfluxMapping(section)%p) - vacancyfluxMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(vacancyConc(section)%p) - vacancyConc(section)%p => vacancyfluxState(section)%state(1,:) - deallocate(vacancyConcRate(section)%p) - allocate(vacancyConcRate(section)%p(NofMyHomog), source=0.0_pReal) - - endif - - enddo initializeInstances -end subroutine vacancyflux_isochempot_init - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates change in vacancy concentration based on local vacancy generation model -!-------------------------------------------------------------------------------------------------- -function vacancyflux_isochempot_updateState(subdt, ip, el) - use numerics, only: & - err_vacancyflux_tolAbs, & - err_vacancyflux_tolRel - use material, only: & - mappingHomogenization, & - vacancyflux_typeInstance, & - vacancyfluxState, & - vacancyConc, & - vacancyConcRate, & - vacancyfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - subdt - logical, dimension(2) :: & - vacancyflux_isochempot_updateState - integer(pInt) :: & - homog, & - offset, & - instance - real(pReal) :: & - Cv, Cvdot, dCvDot_dCv - - homog = mappingHomogenization(2,ip,el) - offset = mappingHomogenization(1,ip,el) - instance = vacancyflux_typeInstance(homog) - - Cv = vacancyfluxState(homog)%subState0(1,offset) - call vacancyflux_isochempot_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) - Cv = Cv + subdt*Cvdot - - vacancyflux_isochempot_updateState = [ abs(Cv - vacancyfluxState(homog)%state(1,offset)) & - <= err_vacancyflux_tolAbs & - .or. abs(Cv - vacancyfluxState(homog)%state(1,offset)) & - <= err_vacancyflux_tolRel*abs(vacancyfluxState(homog)%state(1,offset)), & - .true.] - - vacancyConc (homog)%p(vacancyfluxMapping(homog)%p(ip,el)) = Cv - vacancyConcRate(homog)%p(vacancyfluxMapping(homog)%p(ip,el)) = & - (vacancyfluxState(homog)%state(1,offset) - vacancyfluxState(homog)%subState0(1,offset))/(subdt+tiny(0.0_pReal)) - -end function vacancyflux_isochempot_updateState - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates homogenized vacancy driving forces -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_isochempot_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) - use material, only: & - homogenization_Ngrains, & - mappingHomogenization, & - phaseAt, & - phase_source, & - phase_Nsources, & - SOURCE_vacancy_phenoplasticity_ID, & - SOURCE_vacancy_irradiation_ID, & - SOURCE_vacancy_thermalfluc_ID - use source_vacancy_phenoplasticity, only: & - source_vacancy_phenoplasticity_getRateAndItsTangent - use source_vacancy_irradiation, only: & - source_vacancy_irradiation_getRateAndItsTangent - use source_vacancy_thermalfluc, only: & - source_vacancy_thermalfluc_getRateAndItsTangent - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - Cv - integer(pInt) :: & - phase, & - grain, & - source - real(pReal) :: & - CvDot, dCvDot_dCv, localCvDot, dLocalCvDot_dCv - - CvDot = 0.0_pReal - dCvDot_dCv = 0.0_pReal - do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) - phase = phaseAt(grain,ip,el) - do source = 1_pInt, phase_Nsources(phase) - select case(phase_source(source,phase)) - case (SOURCE_vacancy_phenoplasticity_ID) - call source_vacancy_phenoplasticity_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) - - case (SOURCE_vacancy_irradiation_ID) - call source_vacancy_irradiation_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) - - case (SOURCE_vacancy_thermalfluc_ID) - call source_vacancy_thermalfluc_getRateAndItsTangent(localCvDot, dLocalCvDot_dCv, grain, ip, el) - - end select - CvDot = CvDot + localCvDot - dCvDot_dCv = dCvDot_dCv + dLocalCvDot_dCv - enddo - enddo - - CvDot = CvDot/real(homogenization_Ngrains(mappingHomogenization(2,ip,el)),pReal) - dCvDot_dCv = dCvDot_dCv/real(homogenization_Ngrains(mappingHomogenization(2,ip,el)),pReal) - -end subroutine vacancyflux_isochempot_getSourceAndItsTangent - -!-------------------------------------------------------------------------------------------------- -!> @brief return array of vacancy transport results -!-------------------------------------------------------------------------------------------------- -function vacancyflux_isochempot_postResults(ip,el) - use material, only: & - mappingHomogenization, & - vacancyflux_typeInstance, & - vacancyConc, & - vacancyfluxMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point - el !< element - real(pReal), dimension(vacancyflux_isochempot_sizePostResults(vacancyflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & - vacancyflux_isochempot_postResults - - integer(pInt) :: & - instance, homog, offset, o, c - - homog = mappingHomogenization(2,ip,el) - offset = vacancyfluxMapping(homog)%p(ip,el) - instance = vacancyflux_typeInstance(homog) - - c = 0_pInt - vacancyflux_isochempot_postResults = 0.0_pReal - - do o = 1_pInt,vacancyflux_isochempot_Noutput(instance) - select case(vacancyflux_isochempot_outputID(o,instance)) - - case (vacancyconc_ID) - vacancyflux_isochempot_postResults(c+1_pInt) = vacancyConc(homog)%p(offset) - c = c + 1 - end select - enddo -end function vacancyflux_isochempot_postResults - -end module vacancyflux_isochempot diff --git a/src/vacancyflux_isoconc.f90 b/src/vacancyflux_isoconc.f90 deleted file mode 100644 index 135509aa1..000000000 --- a/src/vacancyflux_isoconc.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for constant vacancy concentration -!-------------------------------------------------------------------------------------------------- -module vacancyflux_isoconc - - implicit none - private - - public :: & - vacancyflux_isoconc_init - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all neccessary fields, reads information from material configuration file -!-------------------------------------------------------------------------------------------------- -subroutine vacancyflux_isoconc_init() -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use prec, only: & - pReal, & - pInt - use IO, only: & - IO_timeStamp - use material - use config - - implicit none - integer(pInt) :: & - homog, & - NofMyHomog - - write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_isoconc_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - - initializeInstances: do homog = 1_pInt, material_Nhomogenization - - myhomog: if (vacancyflux_type(homog) == VACANCYFLUX_isoconc_ID) then - NofMyHomog = count(material_homog == homog) - vacancyfluxState(homog)%sizeState = 0_pInt - vacancyfluxState(homog)%sizePostResults = 0_pInt - allocate(vacancyfluxState(homog)%state0 (0_pInt,NofMyHomog)) - allocate(vacancyfluxState(homog)%subState0(0_pInt,NofMyHomog)) - allocate(vacancyfluxState(homog)%state (0_pInt,NofMyHomog)) - - deallocate(vacancyConc (homog)%p) - allocate (vacancyConc (homog)%p(1), source=vacancyflux_initialCv(homog)) - deallocate(vacancyConcRate(homog)%p) - allocate (vacancyConcRate(homog)%p(1), source=0.0_pReal) - - endif myhomog - enddo initializeInstances - - -end subroutine vacancyflux_isoconc_init - -end module vacancyflux_isoconc From c8dc2cb137b5d18b00c3df1b535fb3aa83a8464b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 11:33:27 +0100 Subject: [PATCH 159/372] best practises from phenopowerlaw --- src/plastic_isotropic.f90 | 254 ++++++++++++++++++-------------------- 1 file changed, 118 insertions(+), 136 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index d65fe583f..da7f5cc0f 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -1,8 +1,8 @@ !-------------------------------------------------------------------------------------------------- !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for isotropic (ISOTROPIC) plasticity -!> @details Isotropic (ISOTROPIC) Plasticity which resembles the phenopowerlaw plasticity without +!> @brief material subroutine for isotropic plasticity +!> @details Isotropic Plasticity which resembles the phenopowerlaw plasticity without !! resolving the stress on the slip systems. Will give the response of phenopowerlaw for an !! untextured polycrystal !-------------------------------------------------------------------------------------------------- @@ -14,52 +14,51 @@ module plastic_isotropic implicit none private integer(pInt), dimension(:,:), allocatable, target, public :: & - plastic_isotropic_sizePostResult !< size of each post result output + 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 - integer(pInt), dimension(:), allocatable, target, public :: & - plastic_isotropic_Noutput !< number of outputs per instance + plastic_isotropic_output !< name of each post result output enum, bind(c) - enumerator :: undefined_ID, & - flowstress_ID, & - strainrate_ID + enumerator :: & + undefined_ID, & + flowstress_ID, & + strainrate_ID end enum - type, private :: tParameters !< container type for internal constitutive parameters - integer(kind(undefined_ID)), allocatable, dimension(:) :: & - outputID + type, private :: tParameters real(pReal) :: & - fTaylor, & - tau0, & - gdot0, & - n, & + fTaylor, & !< Taylor factor + tau0, & !< initial critical stress + gdot0, & !< reference strain rate + n, & !< stress exponent h0, & h0_slopeLnRate, & - tausat, & + tausat, & !< maximum critical stress a, & - aTolFlowstress, & - aTolShear, & tausat_SinhFitA, & tausat_SinhFitB, & tausat_SinhFitC, & - tausat_SinhFitD + tausat_SinhFitD, & + aTolFlowstress, & + aTolShear + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID logical :: & dilatation end type - type(tParameters), dimension(:), allocatable, target, private :: param !< containers of constitutive parameters (len Ninstance) + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - type, private :: tIsotropicState !< internal state aliases - real(pReal), pointer, dimension(:) :: & ! scalars along NipcMyInstance + type, private :: tIsotropicState + real(pReal), pointer, dimension(:) :: & flowstress, & accumulatedShear end type - type(tIsotropicState), allocatable, dimension(:), private :: & !< state aliases per instance - state, & - dotState - + type(tIsotropicState), allocatable, dimension(:), private :: & + dotState, & + state + public :: & plastic_isotropic_init, & plastic_isotropic_LpAndItsTangent, & @@ -80,20 +79,21 @@ subroutine plastic_isotropic_init() compiler_version, & compiler_options #endif -use IO use debug, only: & debug_level, & debug_constitutive, & debug_levelBasic - use numerics, only: & - numerics_integrator use math, only: & math_Mandel3333to66, & math_Voigt66to3333 + use IO, only: & + IO_error, & + IO_timeStamp use material, only: & phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & + material_allocatePlasticState, & PLASTICITY_ISOTROPIC_label, & PLASTICITY_ISOTROPIC_ID, & material_phase, & @@ -101,23 +101,22 @@ use IO use config, only: & MATERIAL_partPhase, & config_phase - use lattice implicit none - type(tParameters), pointer :: prm - integer(pInt) :: & - phase, & + p, & instance, & maxNinstance, & sizeDotState, & - sizeState, & - sizeDeltaState + sizeState character(len=65536) :: & extmsg = '' integer(pInt) :: NipcMyPhase,i + integer(kind(undefined_ID)) :: & + outputID !< ID of each post result output + character(len=65536), dimension(:), allocatable :: outputs write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' @@ -132,117 +131,98 @@ use IO allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), maxNinstance),source=0_pInt) allocate(plastic_isotropic_output(maxval(phase_Noutput), maxNinstance)) plastic_isotropic_output = '' - allocate(plastic_isotropic_Noutput(maxNinstance), source=0_pInt) allocate(param(maxNinstance)) ! one container of parameters per instance allocate(state(maxNinstance)) ! internal state aliases allocate(dotState(maxNinstance)) - do phase = 1_pInt, size(phase_plasticityInstance) - if (phase_plasticity(phase) == PLASTICITY_ISOTROPIC_ID) then - instance = phase_plasticityInstance(phase) - prm => param(instance) ! shorthand pointer to parameter object of my constitutive law - prm%tau0 = config_phase(phase)%getFloat('tau0') - prm%tausat = config_phase(phase)%getFloat('tausat') - prm%gdot0 = config_phase(phase)%getFloat('gdot0') - prm%n = config_phase(phase)%getFloat('n') - prm%h0 = config_phase(phase)%getFloat('h0') - prm%fTaylor = config_phase(phase)%getFloat('m') - prm%h0_slopeLnRate = config_phase(phase)%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) - prm%tausat_SinhFitA = config_phase(phase)%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) - prm%tausat_SinhFitB = config_phase(phase)%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) - prm%tausat_SinhFitC = config_phase(phase)%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) - prm%tausat_SinhFitD = config_phase(phase)%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) - prm%a = config_phase(phase)%getFloat('a') - prm%aTolFlowStress = config_phase(phase)%getFloat('atol_flowstress',defaultVal=1.0_pReal) - prm%aTolShear = config_phase(phase)%getFloat('atol_shear',defaultVal=1.0e-6_pReal) - - prm%dilatation = config_phase(phase)%keyExists('/dilatation/') + do p = 1_pInt, size(phase_plasticityInstance) + if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle + instance = phase_plasticityInstance(p) + associate(prm => param(instance)) + prm%tau0 = config_phase(p)%getFloat('tau0') + prm%tausat = config_phase(p)%getFloat('tausat') + prm%gdot0 = config_phase(p)%getFloat('gdot0') + prm%n = config_phase(p)%getFloat('n') + prm%h0 = config_phase(p)%getFloat('h0') + prm%fTaylor = config_phase(p)%getFloat('m') + prm%h0_slopeLnRate = config_phase(p)%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) + prm%tausat_SinhFitA = config_phase(p)%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) + prm%tausat_SinhFitB = config_phase(p)%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) + prm%tausat_SinhFitC = config_phase(p)%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) + prm%tausat_SinhFitD = config_phase(p)%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) + prm%a = config_phase(p)%getFloat('a') + prm%aTolFlowStress = config_phase(p)%getFloat('atol_flowstress',defaultVal=1.0_pReal) + prm%aTolShear = config_phase(p)%getFloat('atol_shear',defaultVal=1.0e-6_pReal) + + prm%dilatation = config_phase(p)%keyExists('/dilatation/') #if defined(__GFORTRAN__) - outputs = ['GfortranBug86277'] - outputs = config_phase(phase)%getStrings('(output)',defaultVal=outputs) - if (outputs(1) == 'GfortranBug86277') outputs = [character(len=65536)::] + outputs = ['GfortranBug86277'] + outputs = config_phase(p)%getStrings('(output)',defaultVal=outputs) + if (outputs(1) == 'GfortranBug86277') outputs = [character(len=65536)::] #else - outputs = config_phase(phase)%getStrings('(output)',defaultVal=[character(len=65536)::]) + outputs = config_phase(p)%getStrings('(output)',defaultVal=[character(len=65536)::]) #endif - allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) - select case(outputs(i)) - case ('flowstress') - plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt - plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputs(i) - plasticState(phase)%sizePostResults = plasticState(phase)%sizePostResults + 1_pInt - plastic_isotropic_sizePostResult(i,instance) = 1_pInt - prm%outputID = [prm%outputID,flowstress_ID] - case ('strainrate') - plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt - plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputs(i) - plasticState(phase)%sizePostResults = & - plasticState(phase)%sizePostResults + 1_pInt - plastic_isotropic_sizePostResult(i,instance) = 1_pInt - prm%outputID = [prm%outputID,strainrate_ID] - end select - enddo + allocate(prm%outputID(0)) + do i=1_pInt, 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_pInt + prm%outputID = [prm%outputID , outputID] + endif + + enddo !-------------------------------------------------------------------------------------------------- ! 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 (extmsg /= '') call IO_error(211_pInt,ip=instance,& - ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') + 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 (extmsg /= '') call IO_error(211_pInt,ip=instance,& + ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase == phase) ! number of own material points (including point components ipc) + NipcMyPhase = count(material_phase == p) ! number of own material points (including point components ipc) - sizeDotState = size(["flowstress ","accumulated_shear"]) - sizeDeltaState = 0_pInt ! no sudden jumps in state - sizeState = sizeDotState + sizeDeltaState - plasticState(phase)%sizeState = sizeState - plasticState(phase)%sizeDotState = sizeDotState - plasticState(phase)%sizeDeltaState = sizeDeltaState - plasticState(phase)%nSlip = 1 - allocate(plasticState(phase)%aTolState ( sizeState)) - allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%state ( sizeState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase),source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) - allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase),source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase),source=0.0_pReal) + sizeDotState = size(["flowstress ","accumulated_shear"]) + sizeState = sizeDotState + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & + 1_pInt,0_pInt,0_pInt) + !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - state(instance)%flowstress => plasticState(phase)%state (1,1:NipcMyPhase) - dotState(instance)%flowstress => plasticState(phase)%dotState (1,1:NipcMyPhase) - plasticState(phase)%state0(1,1:NipcMyPhase) = prm%tau0 - plasticState(phase)%aTolState(1) = prm%aTolFlowstress + state(instance)%flowstress => plasticState(p)%state (1,1:NipcMyPhase) + dotState(instance)%flowstress => plasticState(p)%dotState (1,1:NipcMyPhase) + plasticState(p)%state0(1,1:NipcMyPhase) = prm%tau0 + plasticState(p)%aTolState(1) = prm%aTolFlowstress - state(instance)%accumulatedShear => plasticState(phase)%state (2,1:NipcMyPhase) - dotState(instance)%accumulatedShear => plasticState(phase)%dotState (2,1:NipcMyPhase) - plasticState(phase)%state0 (2,1:NipcMyPhase) = 0.0_pReal - plasticState(phase)%aTolState(2) = prm%aTolShear - ! global alias - plasticState(phase)%slipRate => plasticState(phase)%dotState(2:2,1:NipcMyPhase) - plasticState(phase)%accumulatedSlip => plasticState(phase)%state (2:2,1:NipcMyPhase) + state(instance)%accumulatedShear => plasticState(p)%state (2,1:NipcMyPhase) + dotState(instance)%accumulatedShear => plasticState(p)%dotState (2,1:NipcMyPhase) + plasticState(p)%state0 (2,1:NipcMyPhase) = 0.0_pReal + plasticState(p)%aTolState(2) = prm%aTolShear + ! global alias + plasticState(p)%slipRate => plasticState(p)%dotState(2:2,1:NipcMyPhase) + plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,1:NipcMyPhase) + end associate -endif enddo end subroutine plastic_isotropic_init @@ -285,7 +265,6 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) ip, & !< integration point el !< element - type(tParameters), pointer :: prm real(pReal), dimension(3,3) :: & Tstar_dev_33 !< deviatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor @@ -301,7 +280,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - prm => param(instance) + associate(prm => param(instance)) Tstar_dev_33 = math_deviatoric33(math_Mandel6to33(Tstar_v)) ! deviatoric part of 2nd Piola-Kirchhoff stress squarenorm_Tstar_dev = math_mul33xx33(Tstar_dev_33,Tstar_dev_33) @@ -338,6 +317,8 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) dLp_dTstar99 = math_Plain3333to99(gamma_dot / prm%fTaylor * & dLp_dTstar_3333 / norm_Tstar_dev) end if + + end associate end subroutine plastic_isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- @@ -366,8 +347,6 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e ipc, & !< component-ID of integration point ip, & !< integration point el !< element - - type(tParameters), pointer :: prm real(pReal), dimension(3,3) :: & Tstar_sph_33 !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor @@ -381,7 +360,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - prm => param(instance) + associate(prm => param(instance)) Tstar_sph_33 = math_spherical33(math_Mandel6to33(Tstar_v)) ! spherical part of 2nd Piola-Kirchhoff stress squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph_33,Tstar_sph_33) @@ -408,6 +387,8 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e Li = 0.0_pReal dLi_dTstar_3333 = 0.0_pReal endif + + end associate end subroutine plastic_isotropic_LiAndItsTangent @@ -431,7 +412,6 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element - type(tParameters), pointer :: prm real(pReal), dimension(6) :: & Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal) :: & @@ -445,7 +425,7 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - prm => param(instance) + associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! norm of (deviatoric) 2nd Piola-Kirchhoff stress @@ -485,6 +465,8 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) dotState(instance)%flowstress (of) = hardening * gamma_dot dotState(instance)%accumulatedShear(of) = gamma_dot + + end associate end subroutine plastic_isotropic_dotState @@ -507,8 +489,6 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element - - type(tParameters), pointer :: prm real(pReal), dimension(plasticState(material_phase(ipc,ip,el))%sizePostResults) :: & plastic_isotropic_postResults @@ -525,7 +505,7 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - prm => param(instance) + associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! norm of (deviatoric) 2nd Piola-Kirchhoff stress @@ -540,7 +520,7 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) c = 0_pInt plastic_isotropic_postResults = 0.0_pReal - outputsLoop: do o = 1_pInt,plastic_isotropic_Noutput(instance) + outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) case (flowstress_ID) plastic_isotropic_postResults(c+1_pInt) = state(instance)%flowstress(of) @@ -553,6 +533,8 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) c = c + 1_pInt end select enddo outputsLoop + + end associate end function plastic_isotropic_postResults From a992b8b1f5d3b170d2b0a53cb0346e07573b9fb4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 11:41:22 +0100 Subject: [PATCH 160/372] random order caused test to fail rather a workaround, but since HDF5 is coming... --- processing/post/addMises.py | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/processing/post/addMises.py b/processing/post/addMises.py index 55cf6552e..5a851fc5a 100755 --- a/processing/post/addMises.py +++ b/processing/post/addMises.py @@ -4,6 +4,7 @@ import os,sys,math import numpy as np from optparse import OptionParser +from collections import OrderedDict import damask scriptName = os.path.splitext(os.path.basename(__file__))[0] @@ -63,10 +64,10 @@ for name in filenames: # ------------------------------------------ sanity checks ---------------------------------------- - items = { + items = OrderedDict({ 'strain': {'dim': 9, 'shape': [3,3], 'labels':options.strain, 'active':[], 'column': []}, 'stress': {'dim': 9, 'shape': [3,3], 'labels':options.stress, 'active':[], 'column': []}, - } + }) errors = [] remarks = [] From 8f99f1ce61c4a3d5bbe22e879f8634f96814482b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 12:35:26 +0100 Subject: [PATCH 161/372] avoid conversion 33<->6 3333<->9 --- src/constitutive.f90 | 9 +++-- src/plastic_isotropic.f90 | 81 +++++++++++++++++---------------------- 2 files changed, 41 insertions(+), 49 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index ce98ced36..7d57299ee 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -479,8 +479,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e dLp_dMp = 0.0_pReal case (PLASTICITY_ISOTROPIC_ID) plasticityType - call plastic_isotropic_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp),ipc,ip,el) - dLp_dMp = math_Plain99to3333(dLp_dMp99) ! ToDo: We revert here the last statement in plastic_xx_LpAndItsTanget + call plastic_isotropic_LpAndItsTangent (Lp,dLp_dMp,Mp,ipc,ip,el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) @@ -527,6 +526,7 @@ end subroutine constitutive_LpAndItsTangents !-------------------------------------------------------------------------------------------------- !> @brief contains the constitutive equation for calculating the velocity gradient +! ToDo: MD: S is Mi? !-------------------------------------------------------------------------------------------------- subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, el) use prec, only: & @@ -535,7 +535,8 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e math_I3, & math_inv33, & math_det33, & - math_mul33x33 + math_mul33x33, & + math_Mandel6to33 use material, only: & phase_plasticity, & material_phase, & @@ -588,7 +589,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_isotropic_ID) plasticityType - call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, S6, ipc, ip, el) + call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, math_Mandel6to33(S6), ipc, ip, el) case default plasticityType my_Li = 0.0_pReal my_dLi_dS = 0.0_pReal diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index da7f5cc0f..ce748212d 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -231,7 +231,7 @@ end subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) +subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) use debug, only: & debug_level, & debug_constitutive, & @@ -242,9 +242,6 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) debug_i, & debug_g use math, only: & - math_mul6x6, & - math_Mandel6to33, & - math_Plain3333to99, & math_deviatoric33, & math_mul33xx33 use material, only: & @@ -253,13 +250,13 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) phase_plasticityInstance implicit none - real(pReal), dimension(3,3), intent(out) :: & + real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(9,9), intent(out) :: & - dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLp_dMp !< derivative of Lp with respect to the Mandel stress - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point @@ -267,13 +264,11 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) real(pReal), dimension(3,3) :: & - Tstar_dev_33 !< deviatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor - real(pReal), dimension(3,3,3,3) :: & - dLp_dTstar_3333 !< derivative of Lp with respect to Tstar as 4th order tensor + Mp_dev !< deviatoric part of the Mandel stress real(pReal) :: & gamma_dot, & !< strainrate - norm_Tstar_dev, & !< euclidean norm of Tstar_dev - squarenorm_Tstar_dev !< square of the euclidean norm of Tstar_dev + norm_Mp_dev, & !< euclidean norm of the Mandel stress + squarenorm_Mp_dev !< square of the euclidean norm of the Mandel stress integer(pInt) :: & instance, of, & k, l, m, n @@ -282,40 +277,38 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) instance = phase_plasticityInstance(material_phase(ipc,ip,el)) associate(prm => param(instance)) - Tstar_dev_33 = math_deviatoric33(math_Mandel6to33(Tstar_v)) ! deviatoric part of 2nd Piola-Kirchhoff stress - squarenorm_Tstar_dev = math_mul33xx33(Tstar_dev_33,Tstar_dev_33) - norm_Tstar_dev = sqrt(squarenorm_Tstar_dev) + Mp_dev = math_deviatoric33(Mp) + squarenorm_Mp_dev = math_mul33xx33(Mp_dev,Mp_dev) + norm_Mp_dev = sqrt(squarenorm_Mp_dev) - if (norm_Tstar_dev <= 0.0_pReal) then ! Tstar == 0 --> both Lp and dLp_dTstar are zero + if (norm_Mp_dev <= 0.0_pReal) then Lp = 0.0_pReal - dLp_dTstar99 = 0.0_pReal + dLp_dMp = 0.0_pReal else gamma_dot = prm%gdot0 & - * ( sqrt(1.5_pReal) * norm_Tstar_dev / prm%fTaylor / state(instance)%flowstress(of) ) & + * ( sqrt(1.5_pReal) * norm_Mp_dev / prm%fTaylor / state(instance)%flowstress(of) ) & **prm%n - Lp = Tstar_dev_33/norm_Tstar_dev * gamma_dot/prm%fTaylor + Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CONST isotropic >> at el ip g ',el,ip,ipc write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & - transpose(Tstar_dev_33(1:3,1:3))*1.0e-6_pReal - write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Tstar_dev*1.0e-6_pReal + 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 !-------------------------------------------------------------------------------------------------- ! Calculation of the tangent of Lp forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dTstar_3333(k,l,m,n) = (prm%n-1.0_pReal) * & - Tstar_dev_33(k,l)*Tstar_dev_33(m,n) / squarenorm_Tstar_dev + dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & - dLp_dTstar_3333(k,l,k,l) = dLp_dTstar_3333(k,l,k,l) + 1.0_pReal + dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & - dLp_dTstar_3333(k,k,m,m) = dLp_dTstar_3333(k,k,m,m) - 1.0_pReal/3.0_pReal - dLp_dTstar99 = math_Plain3333to99(gamma_dot / prm%fTaylor * & - dLp_dTstar_3333 / norm_Tstar_dev) + 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 end if end associate @@ -324,7 +317,7 @@ end subroutine plastic_isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,el) +subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,ipc,ip,el) use math, only: & math_mul6x6, & math_Mandel6to33, & @@ -340,16 +333,16 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e real(pReal), dimension(3,3), intent(out) :: & Li !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & - dLi_dTstar_3333 !< derivative of Li with respect to Tstar as 4th order tensor - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + dLi_dTstar !< derivative of Li with respect to Tstar as 4th order tensor + real(pReal), dimension(3,3), intent(in) :: & + Tstar !< 2nd Piola Kirchhoff stress tensor in Mandel notation integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element real(pReal), dimension(3,3) :: & - Tstar_sph_33 !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor + Tstar_sph !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor real(pReal) :: & gamma_dot, & !< strainrate norm_Tstar_sph, & !< euclidean norm of Tstar_sph @@ -362,30 +355,28 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e instance = phase_plasticityInstance(material_phase(ipc,ip,el)) associate(prm => param(instance)) - Tstar_sph_33 = math_spherical33(math_Mandel6to33(Tstar_v)) ! spherical part of 2nd Piola-Kirchhoff stress - squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph_33,Tstar_sph_33) + 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 ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero + if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero gamma_dot = prm%gdot0 & * (sqrt(1.5_pReal) * norm_Tstar_sph / prm%fTaylor / state(instance)%flowstress(of) ) & **prm%n - Li = Tstar_sph_33/norm_Tstar_sph * gamma_dot/prm%fTaylor + Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor !-------------------------------------------------------------------------------------------------- ! Calculation of the tangent of Li forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLi_dTstar_3333(k,l,m,n) = (prm%n-1.0_pReal) * & - Tstar_sph_33(k,l)*Tstar_sph_33(m,n) / squarenorm_Tstar_sph + 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) & - dLi_dTstar_3333(k,l,k,l) = dLi_dTstar_3333(k,l,k,l) + 1.0_pReal + dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal - dLi_dTstar_3333 = gamma_dot / prm%fTaylor * & - dLi_dTstar_3333 / norm_Tstar_sph + dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph else - Li = 0.0_pReal - dLi_dTstar_3333 = 0.0_pReal + Li = 0.0_pReal + dLi_dTstar = 0.0_pReal endif end associate From b53cda6411f28dc76c8c5aba019d91561daa3c70 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 14:01:05 +0100 Subject: [PATCH 162/372] figuring out "instance" and "of" centrally --- src/constitutive.f90 | 20 ++++++++++++-------- src/plastic_isotropic.f90 | 37 ++++++++++++++----------------------- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 7d57299ee..a33570482 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -538,6 +538,9 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e math_mul33x33, & math_Mandel6to33 use material, only: & + phasememberAt, & + phase_plasticity, & + phase_plasticityInstance, & phase_plasticity, & material_phase, & phase_kinematics, & @@ -569,19 +572,18 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e real(pReal), intent(out), dimension(3,3,3,3) :: & dLi_dS, & !< derivative of Li with respect to S dLi_dFi + real(pReal), dimension(3,3) :: & - my_Li !< intermediate velocity gradient - real(pReal), dimension(3,3,3,3) :: & - my_dLi_dS - real(pReal), dimension(3,3) :: & + my_Li, & !< intermediate velocity gradient FiInv, & temp_33 + real(pReal), dimension(3,3,3,3) :: & + my_dLi_dS real(pReal) :: & detFi integer(pInt) :: & - k !< counter in kinematics loop - integer(pInt) :: & - i, j + k, i, j, & + instance, of Li = 0.0_pReal dLi_dS = 0.0_pReal @@ -589,7 +591,9 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_isotropic_ID) plasticityType - call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, math_Mandel6to33(S6), ipc, ip, el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, math_Mandel6to33(S6),instance,of) case default plasticityType my_Li = 0.0_pReal my_dLi_dS = 0.0_pReal diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index ce748212d..3268c5329 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -314,46 +314,37 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) end associate end subroutine plastic_isotropic_LpAndItsTangent + !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,ipc,ip,el) +subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) use math, only: & - math_mul6x6, & - math_Mandel6to33, & - math_Plain3333to99, & math_spherical33, & math_mul33xx33 - use material, only: & - phasememberAt, & - material_phase, & - phase_plasticityInstance implicit none real(pReal), dimension(3,3), intent(out) :: & - Li !< plastic velocity gradient + Li !< inleastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & - dLi_dTstar !< derivative of Li with respect to Tstar as 4th order tensor - real(pReal), dimension(3,3), intent(in) :: & - Tstar !< 2nd Piola Kirchhoff stress tensor in Mandel notation - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + dLi_dTstar !< derivative of Li with respect to the Mandel stress + real(pReal), dimension(3,3), intent(in) :: & + Tstar !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + real(pReal), dimension(3,3) :: & - Tstar_sph !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor + 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(pInt) :: & - instance, of, & k, l, m, n - of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember - instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - associate(prm => param(instance)) + associate(prm => param(instance), stt => state(instance)) Tstar_sph = math_spherical33(Tstar) squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph,Tstar_sph) @@ -361,8 +352,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,ipc,ip,el) if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero gamma_dot = prm%gdot0 & - * (sqrt(1.5_pReal) * norm_Tstar_sph / prm%fTaylor / state(instance)%flowstress(of) ) & - **prm%n + * (sqrt(1.5_pReal) * norm_Tstar_sph / prm%fTaylor / stt%flowstress(of) ) **prm%n Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor @@ -380,6 +370,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,ipc,ip,el) endif end associate + end subroutine plastic_isotropic_LiAndItsTangent From 892ba86d260ae8f6346b472bbdad0c207d7c31b6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 14:37:31 +0100 Subject: [PATCH 163/372] consistent API --- src/constitutive.f90 | 2 +- src/plastic_isotropic.f90 | 68 ++++++++++++++++----------------------- 2 files changed, 29 insertions(+), 41 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index a33570482..415e3988c 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -861,7 +861,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_ISOTROPIC_ID) plasticityType - call plastic_isotropic_dotState (math_Mandel33to6(Mp),ipc,ip,el) + call plastic_isotropic_dotState (Mp,ipc,ip,el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 3268c5329..da5e4475c 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -300,8 +300,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) 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 -!-------------------------------------------------------------------------------------------------- -! Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & 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) & @@ -312,6 +311,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) end if end associate + end subroutine plastic_isotropic_LpAndItsTangent @@ -331,7 +331,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) real(pReal), dimension(3,3), intent(in) :: & Tstar !< Mandel stress - integer(pInt), intent(in) :: & + integer(pInt), intent(in) :: & instance, & of @@ -350,14 +350,10 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) 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 ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero - gamma_dot = prm%gdot0 & - * (sqrt(1.5_pReal) * norm_Tstar_sph / prm%fTaylor / stt%flowstress(of) ) **prm%n + 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 - - !-------------------------------------------------------------------------------------------------- - ! Calculation of the tangent of Li forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & 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) & @@ -365,8 +361,8 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph else - Li = 0.0_pReal - dLi_dTstar = 0.0_pReal + Li = 0.0_pReal + dLi_dTstar = 0.0_pReal endif end associate @@ -377,52 +373,46 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) !-------------------------------------------------------------------------------------------------- !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) +subroutine plastic_isotropic_dotState(Mp,ipc,ip,el) use prec, only: & dEq0 use math, only: & - math_mul6x6 + math_mul33xx33, & + math_deviatoric33 use material, only: & phasememberAt, & material_phase, & phase_plasticityInstance implicit none - real(pReal), dimension(6), intent(in):: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element - real(pReal), dimension(6) :: & - Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal) :: & gamma_dot, & !< strainrate hardening, & !< hardening coefficient saturation, & !< saturation flowstress - norm_Tstar_v !< euclidean norm of Tstar_dev + norm_Mp !< norm of the Mandel stress integer(pInt) :: & - instance, & !< instance of my instance (unique number of my constitutive model) + instance, & of !< shortcut notation for offset position in state array of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - associate(prm => param(instance)) + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) !-------------------------------------------------------------------------------------------------- -! norm of (deviatoric) 2nd Piola-Kirchhoff stress +! norm of (deviatoric) Mandel stress if (prm%dilatation) then - norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) + norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) else - Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal - Tstar_dev_v(4:6) = Tstar_v(4:6) - norm_Tstar_v = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) - end if -!-------------------------------------------------------------------------------------------------- -! strain rate - gamma_dot = prm%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & - / &!----------------------------------------------------------------------------------- - (prm%fTaylor*state(instance)%flowstress(of) ))**prm%n + 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 !-------------------------------------------------------------------------------------------------- ! hardening coefficient @@ -431,27 +421,25 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) saturation = prm%tausat else saturation = prm%tausat & - + asinh( (gamma_dot / prm%tausat_SinhFitA& - )**(1.0_pReal / prm%tausat_SinhFitD)& + + 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) & - ) + / 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 - state(instance)%flowstress(of)/saturation )**prm%a & - * sign(1.0_pReal, 1.0_pReal - state(instance)%flowstress(of)/saturation) + * 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 - dotState(instance)%flowstress (of) = hardening * gamma_dot - dotState(instance)%accumulatedShear(of) = gamma_dot + dot%flowstress (of) = hardening * gamma_dot + dot%accumulatedShear(of) = gamma_dot end associate end subroutine plastic_isotropic_dotState + !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- From e217ce3a25e01047e88e4b043acf51627e596515 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 15:04:04 +0100 Subject: [PATCH 164/372] fixed output and a few more changes following phenopowerlaw --- src/constitutive.f90 | 2 +- src/plastic_isotropic.f90 | 37 ++++++++++++++++++------------------- 2 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 415e3988c..8ea61e2ae 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1074,7 +1074,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_ISOTROPIC_ID) plasticityType constitutive_postResults(startPos:endPos) = & - plastic_isotropic_postResults(S6,ipc,ip,el) + plastic_isotropic_postResults(Mp,ipc,ip,el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index da5e4475c..4be7c8e46 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -200,10 +200,11 @@ subroutine plastic_isotropic_init() ! allocate state arrays NipcMyPhase = count(material_phase == p) ! number of own material points (including point components ipc) - sizeDotState = size(["flowstress ","accumulated_shear"]) - sizeState = sizeDotState + sizeDotState = size(["flowstress ","accumulated_shear"]) + sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & 1_pInt,0_pInt,0_pInt) + plasticState(p)%sizePostResults = sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(p))) !-------------------------------------------------------------------------------------------------- @@ -330,7 +331,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) dLi_dTstar !< derivative of Li with respect to the Mandel stress real(pReal), dimension(3,3), intent(in) :: & - Tstar !< Mandel stress + Tstar !< Mandel stress ToDo: Mi? integer(pInt), intent(in) :: & instance, & of @@ -443,9 +444,10 @@ end subroutine plastic_isotropic_dotState !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) +function plastic_isotropic_postResults(Mp,ipc,ip,el) use math, only: & - math_mul6x6 + math_mul33xx33, & + math_deviatoric33 use material, only: & plasticState, & material_phase, & @@ -453,20 +455,19 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) phase_plasticityInstance implicit none - real(pReal), dimension(6), intent(in) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element - real(pReal), dimension(plasticState(material_phase(ipc,ip,el))%sizePostResults) :: & - plastic_isotropic_postResults + real(pReal), dimension(sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(material_phase(ipc,ip,el))))) :: & + plastic_isotropic_postResults + - real(pReal), dimension(6) :: & - Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal) :: & - norm_Tstar_v ! euclidean norm of Tstar_dev + norm_Mp !< norm of the Mandel stress integer(pInt) :: & instance, & !< instance of my instance (unique number of my constitutive model) of, & !< shortcut notation for offset position in state array @@ -478,14 +479,12 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- -! norm of (deviatoric) 2nd Piola-Kirchhoff stress +! norm of (deviatoric) Mandel stress if (prm%dilatation) then - norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) + norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) else - Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal - Tstar_dev_v(4:6) = Tstar_v(4:6) - norm_Tstar_v = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) - end if + norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) + endif c = 0_pInt plastic_isotropic_postResults = 0.0_pReal @@ -497,7 +496,7 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) c = c + 1_pInt case (strainrate_ID) plastic_isotropic_postResults(c+1_pInt) = & - prm%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & + prm%gdot0 * ( sqrt(1.5_pReal) * norm_Mp & / &!---------------------------------------------------------------------------------- (prm%fTaylor * state(instance)%flowstress(of)) ) ** prm%n c = c + 1_pInt From 311b8be715dd6bfbef258b09e9ea35d2d0828cc2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 15:14:43 +0100 Subject: [PATCH 165/372] simplifying --- src/constitutive.f90 | 6 ++-- src/plastic_isotropic.f90 | 67 ++++++++++++----------------------- src/plastic_phenopowerlaw.f90 | 1 - 3 files changed, 26 insertions(+), 48 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 8ea61e2ae..651ce1cc3 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -861,7 +861,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_ISOTROPIC_ID) plasticityType - call plastic_isotropic_dotState (Mp,ipc,ip,el) + call plastic_isotropic_dotState (Mp,instance,of) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) @@ -1073,8 +1073,10 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_ISOTROPIC_ID) plasticityType + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) constitutive_postResults(startPos:endPos) = & - plastic_isotropic_postResults(Mp,ipc,ip,el) + plastic_isotropic_postResults(Mp,instance,of) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 4be7c8e46..5196496f3 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -374,35 +374,27 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) !-------------------------------------------------------------------------------------------------- !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_dotState(Mp,ipc,ip,el) +subroutine plastic_isotropic_dotState(Mp,instance,of) use prec, only: & dEq0 use math, only: & math_mul33xx33, & math_deviatoric33 - use material, only: & - phasememberAt, & - material_phase, & - phase_plasticityInstance - + implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + real(pReal) :: & gamma_dot, & !< strainrate hardening, & !< hardening coefficient saturation, & !< saturation flowstress norm_Mp !< norm of the Mandel stress - integer(pInt) :: & - instance, & - of !< shortcut notation for offset position in state array - of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember - instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) !-------------------------------------------------------------------------------------------------- @@ -444,39 +436,27 @@ end subroutine plastic_isotropic_dotState !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- -function plastic_isotropic_postResults(Mp,ipc,ip,el) +function plastic_isotropic_postResults(Mp,instance,of) result(postResults) use math, only: & math_mul33xx33, & math_deviatoric33 - use material, only: & - plasticState, & - material_phase, & - phasememberAt, & - phase_plasticityInstance implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - - real(pReal), dimension(sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(material_phase(ipc,ip,el))))) :: & - plastic_isotropic_postResults + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + real(pReal), dimension(sum(plastic_isotropic_sizePostResult(:,instance))) :: & + postResults real(pReal) :: & norm_Mp !< norm of the Mandel stress integer(pInt) :: & - instance, & !< instance of my instance (unique number of my constitutive model) - of, & !< shortcut notation for offset position in state array - c, & - o + o,c - of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember - instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - associate(prm => param(instance)) + associate(prm => param(instance), stt => state(instance)) !-------------------------------------------------------------------------------------------------- ! norm of (deviatoric) Mandel stress @@ -487,18 +467,15 @@ function plastic_isotropic_postResults(Mp,ipc,ip,el) endif c = 0_pInt - plastic_isotropic_postResults = 0.0_pReal outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) case (flowstress_ID) - plastic_isotropic_postResults(c+1_pInt) = state(instance)%flowstress(of) + postResults(c+1_pInt) = stt%flowstress(of) c = c + 1_pInt case (strainrate_ID) - plastic_isotropic_postResults(c+1_pInt) = & - prm%gdot0 * ( sqrt(1.5_pReal) * norm_Mp & - / &!---------------------------------------------------------------------------------- - (prm%fTaylor * state(instance)%flowstress(of)) ) ** prm%n + postResults(c+1_pInt) = prm%gdot0 & + * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n c = c + 1_pInt end select enddo outputsLoop diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 9ba8dfc01..ce4f8b7f0 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -532,7 +532,6 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip_pos,gdot_slip_neg - postResults = 0.0_pReal c = 0_pInt associate( prm => param(instance), stt => state(instance)) From 2000eff578f0efd6873be85127802c541ff393d4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 15:39:48 +0100 Subject: [PATCH 166/372] re-enabled debug --- src/plastic_kinematichardening.f90 | 47 ++++++++++++++++++++---------- 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index d8076d1a9..b30131535 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -64,7 +64,8 @@ module plastic_kinehardening nonSchmid_pos, & nonSchmid_neg integer(pInt) :: & - totalNslip !< total number of active slip system + totalNslip, & !< total number of active slip system + of_debug = 0_pInt integer(pInt), allocatable, dimension(:) :: & Nslip !< number of active slip systems for each family integer(kind(undefined_ID)), allocatable, dimension(:) :: & @@ -114,6 +115,12 @@ subroutine plastic_kinehardening_init use prec, only: & dEq0 use debug, only: & +#ifdef DEBUG + debug_e, & + debug_i, & + debug_g, & + debug_levelExtensive, & +#endif debug_level, & debug_constitutive,& debug_levelBasic @@ -123,6 +130,9 @@ subroutine plastic_kinehardening_init IO_error, & IO_timeStamp use material, only: & +#ifdef DEBUG + phasememberAt, & +#endif phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & @@ -195,8 +205,13 @@ subroutine plastic_kinehardening_init delta => deltaState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p))) - structure = config_phase(p)%getString('lattice_structure') +#ifdef DEBUG + if (p==material_phase(debug_g,debug_i,debug_e)) then + prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) + endif +#endif + structure = config_phase(p)%getString('lattice_structure') !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined prm%aTolResistance = config_phase(p)%getFloat('atol_resistance',defaultVal=1.0_pReal) @@ -421,7 +436,14 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) use prec, only: & dNeq, & dEq0 - +#ifdef DEBUG + use debug, only: & + debug_level, & + debug_constitutive,& + debug_levelExtensive, & + debug_levelSelective +#endif + implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress @@ -441,16 +463,12 @@ 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 & ! ToDo: We need an inverse mapping of ->el, ip, co -! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & -! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then -! write(6,'(a)') '======= kinehardening delta state =======' -! endif -! if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & -! .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & -! .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then -! write(6,'(i2,1x,f7.4,1x,f7.4)') j,sense(j),state(instance)%sense(j,of) -! endif + 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 + write(6,'(a)') '======= kinehardening delta state =======' + write(6,*) sense,state(instance)%sense(:,of) + endif #endif !-------------------------------------------------------------------------------------------------- @@ -537,9 +555,8 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg - postResults = 0.0_pReal - c = 0_pInt + c = 0_pInt associate( prm => param(instance), stt => state(instance)) From 53d2d4e23de46d35b19835e93d78444371252add Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 16:09:51 +0100 Subject: [PATCH 167/372] re-enabled debug output --- src/constitutive.f90 | 4 +- src/plastic_isotropic.f90 | 87 ++++++++++++++++++++------------------- 2 files changed, 47 insertions(+), 44 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 651ce1cc3..cc5c6f3f8 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -479,7 +479,9 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e dLp_dMp = 0.0_pReal case (PLASTICITY_ISOTROPIC_ID) plasticityType - call plastic_isotropic_LpAndItsTangent (Lp,dLp_dMp,Mp,ipc,ip,el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_isotropic_LpAndItsTangent (Lp,dLp_dMp,Mp,instance,of) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType of = phasememberAt(ipc,ip,el) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 5196496f3..c55a34419 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -26,7 +26,7 @@ module plastic_isotropic end enum type, private :: tParameters - real(pReal) :: & + real(pReal) :: & fTaylor, & !< Taylor factor tau0, & !< initial critical stress gdot0, & !< reference strain rate @@ -41,9 +41,11 @@ module plastic_isotropic tausat_SinhFitD, & aTolFlowstress, & aTolShear - integer(kind(undefined_ID)), allocatable, dimension(:) :: & + integer(pInt) :: & + of_debug = 0_pInt + integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID - logical :: & + logical :: & dilatation end type @@ -80,8 +82,14 @@ subroutine plastic_isotropic_init() compiler_options #endif use debug, only: & +#ifdef DEBUG + debug_e, & + debug_i, & + debug_g, & + debug_levelExtensive, & +#endif debug_level, & - debug_constitutive, & + debug_constitutive,& debug_levelBasic use math, only: & math_Mandel3333to66, & @@ -90,6 +98,9 @@ subroutine plastic_isotropic_init() IO_error, & IO_timeStamp use material, only: & +#ifdef DEBUG + phasememberAt, & +#endif phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & @@ -127,7 +138,7 @@ subroutine plastic_isotropic_init() if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance -! public variables + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), maxNinstance),source=0_pInt) allocate(plastic_isotropic_output(maxval(phase_Noutput), maxNinstance)) plastic_isotropic_output = '' @@ -140,6 +151,13 @@ subroutine plastic_isotropic_init() if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle instance = phase_plasticityInstance(p) associate(prm => param(instance)) + +#ifdef DEBUG + if (p==material_phase(debug_g,debug_i,debug_e)) then + prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) + endif +#endif + prm%tau0 = config_phase(p)%getFloat('tau0') prm%tausat = config_phase(p)%getFloat('tausat') prm%gdot0 = config_phase(p)%getFloat('gdot0') @@ -232,23 +250,17 @@ end subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- -subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) +subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) +#ifdef DEBUG use debug, only: & debug_level, & - debug_constitutive, & - debug_levelBasic, & + debug_constitutive,& debug_levelExtensive, & - debug_levelSelective, & - debug_e, & - debug_i, & - debug_g + debug_levelSelective +#endif use math, only: & math_deviatoric33, & math_mul33xx33 - use material, only: & - phasememberAt, & - material_phase, & - phase_plasticityInstance implicit none real(pReal), dimension(3,3), intent(out) :: & @@ -257,51 +269,41 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) dLp_dMp !< derivative of Lp with respect to the Mandel stress real(pReal), dimension(3,3), intent(in) :: & - Mp + Mp !< Mandel stress integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + instance, & + of - real(pReal), dimension(3,3) :: & Mp_dev !< deviatoric part of the Mandel stress real(pReal) :: & gamma_dot, & !< strainrate - norm_Mp_dev, & !< euclidean norm of the Mandel stress - squarenorm_Mp_dev !< square of the euclidean norm of the Mandel stress + norm_Mp_dev, & !< norm of the deviatoric part of the Mandel stress + squarenorm_Mp_dev !< square of the norm of the deviatoric part of the Mandel stress integer(pInt) :: & - instance, of, & k, l, m, n - of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember - instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - associate(prm => param(instance)) + 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 - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal - else + if (norm_Mp_dev > 0.0_pReal) then gamma_dot = prm%gdot0 & - * ( sqrt(1.5_pReal) * norm_Mp_dev / prm%fTaylor / state(instance)%flowstress(of) ) & + * ( 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_pInt & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CONST isotropic >> at el ip g ',el,ip,ipc + .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) 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) & 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) & @@ -309,6 +311,9 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ipc,ip,el) forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & 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 @@ -318,6 +323,7 @@ end subroutine plastic_isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent +! ToDo: Rename to Tstar to Mi? !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) use math, only: & @@ -392,13 +398,10 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) gamma_dot, & !< strainrate hardening, & !< hardening coefficient saturation, & !< saturation flowstress - norm_Mp !< norm of the Mandel stress - + norm_Mp !< norm of the (deviatoric) Mandel stress associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) -!-------------------------------------------------------------------------------------------------- -! norm of (deviatoric) Mandel stress if (prm%dilatation) then norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) else @@ -407,8 +410,6 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor*stt%flowstress(of))) **prm%n -!-------------------------------------------------------------------------------------------------- -! hardening coefficient if (abs(gamma_dot) > 1e-12_pReal) then if (dEq0(prm%tausat_SinhFitA)) then saturation = prm%tausat From c5dd8d126545a46de6c5642c7ba5e16270d933cf Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 30 Dec 2018 18:11:03 +0100 Subject: [PATCH 168/372] unified style --- src/plastic_isotropic.f90 | 178 +++++++++++++++++----------------- src/plastic_phenopowerlaw.f90 | 31 +++--- 2 files changed, 103 insertions(+), 106 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index c55a34419..a44681676 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -1,6 +1,7 @@ !-------------------------------------------------------------------------------------------------- !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief material subroutine for isotropic plasticity !> @details Isotropic Plasticity which resembles the phenopowerlaw plasticity without !! resolving the stress on the slip systems. Will give the response of phenopowerlaw for an @@ -10,15 +11,15 @@ module plastic_isotropic use prec, only: & pReal,& pInt - + implicit none private integer(pInt), 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) + + enum, bind(c) enumerator :: & undefined_ID, & flowstress_ID, & @@ -50,9 +51,9 @@ module plastic_isotropic end type type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - + type, private :: tIsotropicState - real(pReal), pointer, dimension(:) :: & + real(pReal), pointer, dimension(:) :: & flowstress, & accumulatedShear end type @@ -60,8 +61,8 @@ module plastic_isotropic type(tIsotropicState), allocatable, dimension(:), private :: & dotState, & state - - public :: & + + public :: & plastic_isotropic_init, & plastic_isotropic_LpAndItsTangent, & plastic_isotropic_LiAndItsTangent, & @@ -81,6 +82,8 @@ subroutine plastic_isotropic_init() compiler_version, & compiler_options #endif + use prec, only: & + pStringLen use debug, only: & #ifdef DEBUG debug_e, & @@ -91,9 +94,6 @@ subroutine plastic_isotropic_init() debug_level, & debug_constitutive,& debug_levelBasic - use math, only: & - math_Mandel3333to66, & - math_Voigt66to3333 use IO, only: & IO_error, & IO_timeStamp @@ -112,76 +112,94 @@ subroutine plastic_isotropic_init() use config, only: & MATERIAL_partPhase, & config_phase - use lattice + use lattice implicit none - integer(pInt) :: & - p, & - instance, & - maxNinstance, & - sizeDotState, & - sizeState - character(len=65536) :: & - extmsg = '' - integer(pInt) :: NipcMyPhase,i + Ninstance, & + p, i, & + NipcMyPhase, & + sizeState, sizeDotState + + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & - outputID !< ID of each post result output + outputID - character(len=65536), dimension(:), allocatable :: outputs + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs - write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' + 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' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - - maxNinstance = int(count(phase_plasticity == PLASTICITY_ISOTROPIC_ID),pInt) + + Ninstance = int(count(phase_plasticity == PLASTICITY_ISOTROPIC_ID),pInt) if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), maxNinstance),source=0_pInt) - allocate(plastic_isotropic_output(maxval(phase_Noutput), maxNinstance)) + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), Ninstance),source=0_pInt) + allocate(plastic_isotropic_output(maxval(phase_Noutput), Ninstance)) plastic_isotropic_output = '' - allocate(param(maxNinstance)) ! one container of parameters per instance - allocate(state(maxNinstance)) ! internal state aliases - allocate(dotState(maxNinstance)) + allocate(param(Ninstance)) + allocate(state(Ninstance)) + allocate(dotState(Ninstance)) do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle - instance = phase_plasticityInstance(p) - associate(prm => param(instance)) + 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) + prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) endif #endif - prm%tau0 = config_phase(p)%getFloat('tau0') - prm%tausat = config_phase(p)%getFloat('tausat') - prm%gdot0 = config_phase(p)%getFloat('gdot0') - prm%n = config_phase(p)%getFloat('n') - prm%h0 = config_phase(p)%getFloat('h0') - prm%fTaylor = config_phase(p)%getFloat('m') - prm%h0_slopeLnRate = config_phase(p)%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) - prm%tausat_SinhFitA = config_phase(p)%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) - prm%tausat_SinhFitB = config_phase(p)%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) - prm%tausat_SinhFitC = config_phase(p)%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) - prm%tausat_SinhFitD = config_phase(p)%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) - prm%a = config_phase(p)%getFloat('a') - prm%aTolFlowStress = config_phase(p)%getFloat('atol_flowstress',defaultVal=1.0_pReal) - prm%aTolShear = config_phase(p)%getFloat('atol_shear',defaultVal=1.0e-6_pReal) + 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_phase(p)%keyExists('/dilatation/') + prm%dilatation = config%keyExists('/dilatation/') -#if defined(__GFORTRAN__) - outputs = ['GfortranBug86277'] - outputs = config_phase(p)%getStrings('(output)',defaultVal=outputs) - if (outputs(1) == 'GfortranBug86277') outputs = [character(len=65536)::] -#else - outputs = config_phase(p)%getStrings('(output)',defaultVal=[character(len=65536)::]) -#endif +!-------------------------------------------------------------------------------------------------- +! 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 ' + +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,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) outputID = undefined_ID @@ -198,48 +216,34 @@ subroutine plastic_isotropic_init() prm%outputID = [prm%outputID , outputID] endif - enddo - -!-------------------------------------------------------------------------------------------------- -! 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 (extmsg /= '') call IO_error(211_pInt,ip=instance,& - ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') + end do !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase == p) ! number of own material points (including point components ipc) + NipcMyPhase = count(material_phase == p) + sizeState = size(["flowstress ","accumulated_shear"]) + sizeDotState = sizeState - sizeDotState = size(["flowstress ","accumulated_shear"]) - sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & 1_pInt,0_pInt,0_pInt) plasticState(p)%sizePostResults = sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(p))) - !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - - state(instance)%flowstress => plasticState(p)%state (1,1:NipcMyPhase) - dotState(instance)%flowstress => plasticState(p)%dotState (1,1:NipcMyPhase) - plasticState(p)%state0(1,1:NipcMyPhase) = prm%tau0 + stt%flowstress => plasticState(p)%state (1,1:NipcMyPhase) + stt%flowstress = prm%tau0 + dot%flowstress => plasticState(p)%dotState (1,1:NipcMyPhase) plasticState(p)%aTolState(1) = prm%aTolFlowstress - state(instance)%accumulatedShear => plasticState(p)%state (2,1:NipcMyPhase) - dotState(instance)%accumulatedShear => plasticState(p)%dotState (2,1:NipcMyPhase) - plasticState(p)%state0 (2,1:NipcMyPhase) = 0.0_pReal + stt%accumulatedShear => plasticState(p)%state (2,1:NipcMyPhase) + dot%accumulatedShear => plasticState(p)%dotState (2,1:NipcMyPhase) plasticState(p)%aTolState(2) = prm%aTolShear ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(2:2,1:NipcMyPhase) plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,1:NipcMyPhase) + + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + end associate enddo @@ -290,9 +294,7 @@ 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%fTaylor*stt%flowstress(of))) **prm%n Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor #ifdef DEBUG @@ -323,7 +325,7 @@ end subroutine plastic_isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent -! ToDo: Rename to Tstar to Mi? +! ToDo: Rename Tstar to Mi? !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) use math, only: & @@ -459,8 +461,6 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) associate(prm => param(instance), stt => state(instance)) -!-------------------------------------------------------------------------------------------------- -! norm of (deviatoric) Mandel stress if (prm%dilatation) then norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) else diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index ce4f8b7f0..1e42876f9 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -82,8 +82,7 @@ module plastic_phenopowerlaw xi_slip, & xi_twin, & gamma_slip, & - gamma_twin, & - whole + gamma_twin end type type(tPhenopowerlawState), allocatable, dimension(:), private :: & @@ -95,6 +94,9 @@ module plastic_phenopowerlaw plastic_phenopowerlaw_LpAndItsTangent, & plastic_phenopowerlaw_dotState, & plastic_phenopowerlaw_postResults + private :: & + kinetics_slip, & + kinetics_twin contains @@ -110,8 +112,7 @@ subroutine plastic_phenopowerlaw_init compiler_options #endif use prec, only: & - pStringLen, & - dEq0 + pStringLen use debug, only: & debug_level, & debug_constitutive,& @@ -119,7 +120,6 @@ subroutine plastic_phenopowerlaw_init use math, only: & math_expand use IO, only: & - IO_warning, & IO_error, & IO_timeStamp use material, only: & @@ -149,7 +149,7 @@ subroutine plastic_phenopowerlaw_init character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & - outputID !< ID of each post result output + outputID character(len=pStringLen) :: & structure = '',& @@ -157,7 +157,7 @@ subroutine plastic_phenopowerlaw_init character(len=65536), dimension(:), allocatable :: & outputs - write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_PHENOPOWERLAW_label//' init -+>>>' + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_PHENOPOWERLAW_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -207,7 +207,7 @@ subroutine plastic_phenopowerlaw_init config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& - defaultVal = emptyRealArray) + defaultVal = emptyRealArray) prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1_pInt) prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) else @@ -221,7 +221,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_pInt,size(prm%Nslip))]) prm%gdot0_slip = config%getFloat('gdot0_slip') prm%n_slip = config%getFloat('n_slip') @@ -234,9 +234,9 @@ subroutine plastic_phenopowerlaw_init prm%H_int = math_expand(prm%H_int, prm%Nslip) ! sanity checks - if (prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//'gdot0_slip ' - if (dEq0(prm%a_slip)) extmsg = trim(extmsg)//'a_slip ' ! ToDo: negative values ok? - if (dEq0(prm%n_slip)) extmsg = trim(extmsg)//'n_slip ' ! ToDo: negative values ok? + if (prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//'gdot0_slip ' + if (prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//'a_slip ' + if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//'n_slip ' if (any(prm%xi_slip_0 <= 0.0_pReal)) extmsg = trim(extmsg)//'xi_slip_0 ' if (any(prm%xi_slip_sat < prm%xi_slip_0)) extmsg = trim(extmsg)//'xi_slip_sat ' else slipActive @@ -269,7 +269,7 @@ subroutine plastic_phenopowerlaw_init ! sanity checks if (prm%gdot0_twin <= 0.0_pReal) extmsg = trim(extmsg)//'gdot0_twin ' - if (dEq0(prm%n_twin)) extmsg = trim(extmsg)//'n_twin ' ! ToDo: negative values ok? + if (prm%n_twin <= 0.0_pReal) extmsg = trim(extmsg)//'n_twin ' else twinActive allocate(prm%interaction_TwinTwin(0,0)) allocate(prm%xi_twin_0(0)) @@ -341,7 +341,7 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase == p) ! number of IPCs containing my phase + NipcMyPhase = count(material_phase == p) sizeState = size(['tau_slip ','gamma_slip']) * prm%TotalNslip & + size(['tau_twin ','gamma_twin']) * prm%TotalNtwin sizeDotState = sizeState @@ -350,7 +350,6 @@ subroutine plastic_phenopowerlaw_init prm%totalNslip,prm%totalNtwin,0_pInt) plasticState(p)%sizePostResults = sum(plastic_phenopowerlaw_sizePostResult(:,phase_plasticityInstance(p))) - !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState startIndex = 1_pInt @@ -383,7 +382,6 @@ subroutine plastic_phenopowerlaw_init plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally - dot%whole => plasticState(p)%dotState end associate enddo @@ -469,7 +467,6 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) - dot%whole(:,of) = 0.0_pReal sumGamma = sum(stt%gamma_slip(:,of)) sumF = sum(stt%gamma_twin(:,of)/prm%gamma_twin_char) From 6f40989465454c4bd78b68b7fe72389ee79528aa Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 31 Dec 2018 07:18:45 +0100 Subject: [PATCH 169/372] order was randomized when creating dict --- processing/post/addMises.py | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/processing/post/addMises.py b/processing/post/addMises.py index 5a851fc5a..7e757ed9d 100755 --- a/processing/post/addMises.py +++ b/processing/post/addMises.py @@ -64,10 +64,10 @@ for name in filenames: # ------------------------------------------ sanity checks ---------------------------------------- - items = OrderedDict({ - 'strain': {'dim': 9, 'shape': [3,3], 'labels':options.strain, 'active':[], 'column': []}, - 'stress': {'dim': 9, 'shape': [3,3], 'labels':options.stress, 'active':[], 'column': []}, - }) + items = OrderedDict([ + ('strain', {'dim': 9, 'shape': [3,3], 'labels':options.strain, 'active':[], 'column': []}), + ('stress', {'dim': 9, 'shape': [3,3], 'labels':options.stress, 'active':[], 'column': []}) + ]) errors = [] remarks = [] From 835e3f95a5f5e9d2f54f3b36c67bc65b43c3d8ed Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 31 Dec 2018 08:05:56 +0100 Subject: [PATCH 170/372] [skip ci] was not used --- processing/post/addEuclideanDistance.py | 1 - 1 file changed, 1 deletion(-) diff --git a/processing/post/addEuclideanDistance.py b/processing/post/addEuclideanDistance.py index 2e5794e1b..f759b7a8f 100755 --- a/processing/post/addEuclideanDistance.py +++ b/processing/post/addEuclideanDistance.py @@ -149,7 +149,6 @@ for name in filenames: errors = [] remarks = [] - column = {} if not 3 >= table.label_dimension(options.pos) >= 1: errors.append('coordinates "{}" need to have one, two, or three dimensions.'.format(options.pos)) From 4d0166351ecf9ae3ed151ca1407fd27da0404c45 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 31 Dec 2018 11:35:01 +0100 Subject: [PATCH 171/372] missing initialization caused segmentation fault --- src/constitutive.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index cc5c6f3f8..b20d6e65d 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -863,6 +863,8 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_ISOTROPIC_ID) plasticityType + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) call plastic_isotropic_dotState (Mp,instance,of) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType From a852729d4d7ce028fbada072add19be878d5ede5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 1 Jan 2019 16:59:35 +0100 Subject: [PATCH 172/372] [skip ci] it's 2019 now --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 630dc3a84..1ab20178c 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2011-18 Max-Planck-Institut für Eisenforschung GmbH +Copyright 2011-19 Max-Planck-Institut für Eisenforschung GmbH DAMASK is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by From b5d62c8e29a426158ca338458666088015022291 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Thu, 3 Jan 2019 11:28:03 -0500 Subject: [PATCH 173/372] [skip ci] print estimated remaining processing time for postResults --- lib/damask/util.py | 13 ++++++++++--- processing/post/postResults.py | 12 ++++++++---- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/lib/damask/util.py b/lib/damask/util.py index e7d4a16bc..45347ae88 100644 --- a/lib/damask/util.py +++ b/lib/damask/util.py @@ -134,7 +134,7 @@ class extendableOption(Option): # Print iterations progress # from https://gist.github.com/aubricus/f91fb55dc6ba5557fbab06119420dd6a -def progressBar(iteration, total, prefix='', suffix='', decimals=1, bar_length=100): +def progressBar(iteration, total, start=None, prefix='', suffix='', decimals=1, bar_length=50): """ Call in a loop to create terminal progress bar @@ -146,12 +146,19 @@ def progressBar(iteration, total, prefix='', suffix='', decimals=1, bar_length=1 decimals - Optional : positive number of decimals in percent complete (Int) bar_length - Optional : character length of bar (Int) """ - str_format = "{0:." + str(decimals) + "f}" + import time + + if suffix == '' and start is not None and iteration > 0: + remainder = (total - iteration) * (time.time()-start)/iteration + suffix = '{: 3d}:'.format(int( remainder//3600)) + \ + '{:02d}:'.format(int((remainder//60)%60)) + \ + '{:02d}' .format(int( remainder %60)) + str_format = "{{0:{}.{}f}}".format(decimals+4,decimals) percents = str_format.format(100 * (iteration / float(total))) filled_length = int(round(bar_length * iteration / float(total))) bar = '█' * filled_length + '-' * (bar_length - filled_length) - sys.stderr.write('\r%s |%s| %s%s %s' % (prefix, bar, percents, '%', suffix)), + sys.stderr.write('\r%s |%s| %s %s' % (prefix, bar, percents+'%', suffix)), if iteration == total: sys.stderr.write('\n\n') sys.stderr.flush() diff --git a/processing/post/postResults.py b/processing/post/postResults.py index a5a2669d7..cf4353ac5 100755 --- a/processing/post/postResults.py +++ b/processing/post/postResults.py @@ -830,9 +830,10 @@ if options.info: elementsOfNode = {} Nelems = stat['NumberOfElements'] +starttime = time.time() for e in range(Nelems): if options.verbose and Nelems > 100 and e%(Nelems//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=e,total=Nelems,prefix='1/3: connecting elements') + damask.util.progressBar(iteration=e,total=Nelems,start=starttime,prefix='1/3: connecting elements') for n in map(p.node_sequence,p.element(e).items): if n not in elementsOfNode: elementsOfNode[n] = [p.element_id(e)] @@ -855,9 +856,10 @@ damask.util.progressBar(iteration=1,total=1,prefix='1/3: connecting elements') if options.nodalScalar: Npoints = stat['NumberOfNodes'] + starttime = time.time() for n in range(Npoints): if options.verbose and Npoints > 100 and e%(Npoints//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=n,total=Npoints,prefix='2/3: scanning nodes ') + damask.util.progressBar(iteration=n,total=Npoints,start=starttime,prefix='2/3: scanning nodes ') myNodeID = p.node_id(n) myNodeCoordinates = [p.node(n).x, p.node(n).y, p.node(n).z] myElemID = 0 @@ -892,9 +894,10 @@ if options.nodalScalar: else: Nelems = stat['NumberOfElements'] + starttime = time.time() for e in range(Nelems): if options.verbose and Nelems > 100 and e%(Nelems//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=e,total=Nelems,prefix='2/3: scanning elements ') + damask.util.progressBar(iteration=e,total=Nelems,start=starttime,prefix='2/3: scanning elements ') myElemID = p.element_id(e) myIpCoordinates = ipCoords(p.element(e).type, list(map(lambda node: [node.x, node.y, node.z], list(map(p.node, map(p.node_sequence, p.element(e).items)))))) @@ -1032,10 +1035,11 @@ for incCount,position in enumerate(locations): # walk through locations member = 0 Ngroups = len(groups) + starttime = time.time() for j,group in enumerate(groups): f = incCount*Ngroups + j if options.verbose and (Ngroups*Nincs) > 100 and f%((Ngroups*Nincs)//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=f,total=Ngroups*Nincs,prefix='3/3: processing points ') + damask.util.progressBar(iteration=f,total=Ngroups*Nincs,start=starttime,prefix='3/3: processing points ') N = 0 # group member counter for (e,n,i,g,n_local) in group[1:]: # loop over group members member += 1 From bcd4288f1eba6eba0fe21b35326ed5447415eb69 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Thu, 3 Jan 2019 18:25:28 -0500 Subject: [PATCH 174/372] [skip ci] groupTable according to unique values in more than one column --- processing/post/groupTable.py | 44 +++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 18 deletions(-) diff --git a/processing/post/groupTable.py b/processing/post/groupTable.py index 67d07a7d1..f78566304 100755 --- a/processing/post/groupTable.py +++ b/processing/post/groupTable.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -21,18 +21,19 @@ scriptID = ' '.join([scriptName,damask.version]) # -------------------------------------------------------------------- parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ -Apply a user-specified function to condense all rows for which column 'label' has identical values into a single row. -Output table will contain as many rows as there are different (unique) values in the grouping column. +Apply a user-specified function to condense into a single row all those rows for which columns 'label' have identical values. +Output table will contain as many rows as there are different (unique) values in the grouping column(s). Periodic domain averaging of coordinate values is supported. Examples: For grain averaged values, replace all rows of particular 'texture' with a single row containing their average. -""", version = scriptID) +{name} --label texture --function np.average data.txt +""".format(name = scriptName), version = scriptID) parser.add_option('-l','--label', dest = 'label', - type = 'string', metavar = 'string', - help = 'column label for grouping rows') + action = 'extend', metavar = '', + help = 'column label(s) for grouping rows') parser.add_option('-f','--function', dest = 'function', type = 'string', metavar = 'string', @@ -40,7 +41,7 @@ parser.add_option('-f','--function', parser.add_option('-a','--all', dest = 'all', action = 'store_true', - help = 'apply mapping function also to grouping column') + help = 'apply mapping function also to grouping column(s)') group = OptionGroup(parser, "periodic averaging", "") @@ -57,6 +58,7 @@ parser.add_option_group(group) parser.set_defaults(function = 'np.average', all = False, + label = [], boundary = [0.0, 1.0]) (options,filenames) = parser.parse_args() @@ -71,7 +73,7 @@ try: except: mapFunction = None -if options.label is None: +if options.label is []: parser.error('no grouping column specified.') if not hasattr(mapFunction,'__call__'): parser.error('function "{}" is not callable.'.format(options.function)) @@ -89,13 +91,20 @@ for name in filenames: # ------------------------------------------ sanity checks --------------------------------------- + remarks = [] + errors = [] + table.head_read() - if table.label_dimension(options.label) != 1: - damask.util.croak('column {} is not of scalar dimension.'.format(options.label)) - table.close(dismiss = True) # close ASCIItable and remove empty file + grpColumns = table.label_index(options.label)[::-1] + grpColumns = grpColumns[np.where(grpColumns>=0)] + + if len(grpColumns) == 0: errors.append('no valid grouping column present.') + + if remarks != []: damask.util.croak(remarks) + if errors != []: + damask.util.croak(errors) + table.close(dismiss=True) continue - else: - grpColumn = table.label_index(options.label) # ------------------------------------------ assemble info --------------------------------------- @@ -108,10 +117,9 @@ for name in filenames: indexrange = table.label_indexrange(options.periodic) if options.periodic is not None else [] rows,cols = table.data.shape - table.data = table.data[np.lexsort([table.data[:,grpColumn]])] # sort data by grpColumn - - values,index = np.unique(table.data[:,grpColumn], return_index = True) # unique grpColumn values and their positions - index = np.append(index,rows) # add termination position + table.data = table.data[np.lexsort(table.data[:,grpColumns].T)] # sort data by grpColumn(s) + values,index = np.unique(table.data[:,grpColumns], axis=0, return_index=True) # unique grpColumn values and their positions + index = sorted(np.append(index,rows)) # add termination position grpTable = np.empty((len(values), cols)) # initialize output for i in range(len(values)): # iterate over groups (unique values in grpColumn) @@ -119,7 +127,7 @@ for name in filenames: grpTable[i,indexrange] = \ periodicAverage(table.data[index[i]:index[i+1],indexrange],options.boundary) # apply periodicAverage mapping function - if not options.all: grpTable[i,grpColumn] = table.data[index[i],grpColumn] # restore grouping column value + if not options.all: grpTable[i,grpColumns] = table.data[index[i],grpColumns] # restore grouping column value table.data = grpTable From 3c5df0a4a43f5ddabb0c17a49e50d9474c5cf1ee Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Fri, 4 Jan 2019 16:34:04 -0500 Subject: [PATCH 175/372] [skip ci] viewTable acknowledges requested output type(s) --- processing/post/viewTable.py | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/processing/post/viewTable.py b/processing/post/viewTable.py index c01bdcddb..309f229e1 100755 --- a/processing/post/viewTable.py +++ b/processing/post/viewTable.py @@ -61,7 +61,14 @@ for name in filenames: table = damask.ASCIItable(name = name, buffered = False, labeled = options.labeled, readonly = True) except: continue - damask.util.report(scriptName,name) + details = ', '.join( + (['header'] if options.table else []) + + (['info'] if options.head or options.info else []) + + (['labels'] if options.head or options.labels else []) + + (['data'] if options.data else []) + + [] + ) + damask.util.report(scriptName,name + ('' if details == '' else ' -- '+details)) # ------------------------------------------ output head --------------------------------------- From 2f3b5185623da4fdcadf438e2c7bcb9ae07a7304 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 10:06:37 +0100 Subject: [PATCH 176/372] rename was missing --- src/plastic_none.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index 5470c4a43..5b5bb49d1 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -48,7 +48,7 @@ subroutine plastic_none_init phase, & NofMyPhase - write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_NONE_label//' init -+>>>' + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" From 7768c5874bed4165f2af9de7a980e70e191a8cc3 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 10:41:49 +0100 Subject: [PATCH 177/372] simpler interface for progress bar --- lib/damask/util.py | 37 ++++++++++++++++++++-------------- processing/post/postResults.py | 22 +++++++++----------- 2 files changed, 31 insertions(+), 28 deletions(-) diff --git a/lib/damask/util.py b/lib/damask/util.py index 45347ae88..5def68bf6 100644 --- a/lib/damask/util.py +++ b/lib/damask/util.py @@ -1,5 +1,5 @@ # -*- coding: UTF-8 no BOM -*- -import sys,time,random,threading,os,subprocess,shlex +import sys,time,random,threading,os,subprocess,shlex,time import numpy as np from optparse import Option @@ -134,7 +134,7 @@ class extendableOption(Option): # Print iterations progress # from https://gist.github.com/aubricus/f91fb55dc6ba5557fbab06119420dd6a -def progressBar(iteration, total, start=None, prefix='', suffix='', decimals=1, bar_length=50): +def progressBar(iteration, total, prefix='', bar_length=50): """ Call in a loop to create terminal progress bar @@ -142,23 +142,30 @@ def progressBar(iteration, total, start=None, prefix='', suffix='', decimals=1, iteration - Required : current iteration (Int) total - Required : total iterations (Int) prefix - Optional : prefix string (Str) - suffix - Optional : suffix string (Str) - decimals - Optional : positive number of decimals in percent complete (Int) bar_length - Optional : character length of bar (Int) """ - import time - if suffix == '' and start is not None and iteration > 0: - remainder = (total - iteration) * (time.time()-start)/iteration - suffix = '{: 3d}:'.format(int( remainder//3600)) + \ - '{:02d}:'.format(int((remainder//60)%60)) + \ - '{:02d}' .format(int( remainder %60)) - str_format = "{{0:{}.{}f}}".format(decimals+4,decimals) - percents = str_format.format(100 * (iteration / float(total))) - filled_length = int(round(bar_length * iteration / float(total))) - bar = '█' * filled_length + '-' * (bar_length - filled_length) + fraction = iteration / float(total) + if not hasattr(progressBar, "last_fraction"): # first call to function + progressBar.start_time = time.time() + progressBar.last_fraction = -1.0 + remaining_time = ' n/a' + else: + if fraction <= progressBar.last_fraction or iteration == 0: # reset: called within a new loop + progressBar.start_time = time.time() + progressBar.last_fraction = -1.0 + remaining_time = ' n/a' + else: + progressBar.last_fraction = fraction + remainder = (total - iteration) * (time.time()-progressBar.start_time)/iteration + remaining_time = '{: 3d}:'.format(int( remainder//3600)) + \ + '{:02d}:'.format(int((remainder//60)%60)) + \ + '{:02d}' .format(int( remainder %60)) - sys.stderr.write('\r%s |%s| %s %s' % (prefix, bar, percents+'%', suffix)), + filled_length = int(round(bar_length * fraction)) + bar = '█' * filled_length + '░' * (bar_length - filled_length) + + sys.stderr.write('\r{} {} {}'.format(prefix, bar, remaining_time)), if iteration == total: sys.stderr.write('\n\n') sys.stderr.flush() diff --git a/processing/post/postResults.py b/processing/post/postResults.py index cf4353ac5..c0885a967 100755 --- a/processing/post/postResults.py +++ b/processing/post/postResults.py @@ -830,10 +830,9 @@ if options.info: elementsOfNode = {} Nelems = stat['NumberOfElements'] -starttime = time.time() for e in range(Nelems): - if options.verbose and Nelems > 100 and e%(Nelems//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=e,total=Nelems,start=starttime,prefix='1/3: connecting elements') + if options.verbose and Nelems >= 50 and e%(Nelems//50) == 0: # report in 2% steps if possible and avoid modulo by zero + damask.util.progressBar(iteration=e,total=Nelems,prefix='1/3: connecting elements') for n in map(p.node_sequence,p.element(e).items): if n not in elementsOfNode: elementsOfNode[n] = [p.element_id(e)] @@ -856,10 +855,9 @@ damask.util.progressBar(iteration=1,total=1,prefix='1/3: connecting elements') if options.nodalScalar: Npoints = stat['NumberOfNodes'] - starttime = time.time() for n in range(Npoints): - if options.verbose and Npoints > 100 and e%(Npoints//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=n,total=Npoints,start=starttime,prefix='2/3: scanning nodes ') + if options.verbose and Npoints >= 50 and e%(Npoints//50) == 0: # report in 2% steps if possible and avoid modulo by zero + damask.util.progressBar(iteration=n,total=Npoints,prefix='2/3: scanning nodes ') myNodeID = p.node_id(n) myNodeCoordinates = [p.node(n).x, p.node(n).y, p.node(n).z] myElemID = 0 @@ -894,10 +892,9 @@ if options.nodalScalar: else: Nelems = stat['NumberOfElements'] - starttime = time.time() for e in range(Nelems): - if options.verbose and Nelems > 100 and e%(Nelems//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=e,total=Nelems,start=starttime,prefix='2/3: scanning elements ') + if options.verbose and Nelems >= 50 and e%(Nelems//50) == 0: # report in 2% steps if possible and avoid modulo by zero + damask.util.progressBar(iteration=e,total=Nelems,prefix='2/3: scanning elements ') myElemID = p.element_id(e) myIpCoordinates = ipCoords(p.element(e).type, list(map(lambda node: [node.x, node.y, node.z], list(map(p.node, map(p.node_sequence, p.element(e).items)))))) @@ -1035,11 +1032,10 @@ for incCount,position in enumerate(locations): # walk through locations member = 0 Ngroups = len(groups) - starttime = time.time() for j,group in enumerate(groups): f = incCount*Ngroups + j - if options.verbose and (Ngroups*Nincs) > 100 and f%((Ngroups*Nincs)//100) == 0: # report in 1% steps if possible and avoid modulo by zero - damask.util.progressBar(iteration=f,total=Ngroups*Nincs,start=starttime,prefix='3/3: processing points ') + if options.verbose and (Ngroups*Nincs) >= 50 and f%((Ngroups*Nincs)//50) == 0: # report in 2% steps if possible and avoid modulo by zero + damask.util.progressBar(iteration=f,total=Ngroups*Nincs,prefix='3/3: processing points ') N = 0 # group member counter for (e,n,i,g,n_local) in group[1:]: # loop over group members member += 1 @@ -1091,7 +1087,7 @@ for incCount,position in enumerate(locations): # walk through locations ['Crystallite']*len(options.crystalliteResult) + ['Constitutive']*len(options.constitutiveResult) ): - outputIndex = (list(zip(*outputFormat[resultType]['outputs']))[0]).index(label) # find the position of this output in the outputFormat + outputIndex = (list(zip(*outputFormat[resultType]['outputs']))[0]).index(label) # find the position of this output in the outputFormat length = int(outputFormat[resultType]['outputs'][outputIndex][1]) thisHead = heading('_',[[component,''.join( label.split() )] for component in range(int(length>1),length+int(length>1))]) if assembleHeader: header += thisHead From 02ab55d4b3bac57431c91004b31d9fdfdfddb887 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 10:52:39 +0100 Subject: [PATCH 178/372] python reflects content better than lib --- env/DAMASK.csh | 4 ++-- env/DAMASK.sh | 2 +- env/DAMASK.zsh | 2 +- {lib => python}/damask/.gitignore | 0 {lib => python}/damask/__init__.py | 0 {lib => python}/damask/asciitable.py | 0 {lib => python}/damask/colormaps.py | 0 {lib => python}/damask/config/__init__.py | 0 {lib => python}/damask/config/material.py | 0 {lib => python}/damask/environment.py | 0 {lib => python}/damask/geometry/__init__.py | 0 {lib => python}/damask/geometry/geometry.py | 0 {lib => python}/damask/geometry/marc.py | 0 {lib => python}/damask/geometry/spectral.py | 0 {lib => python}/damask/orientation.py | 0 {lib => python}/damask/result.py | 0 {lib => python}/damask/result/marc2vtk.py | 0 {lib => python}/damask/solver/__init__.py | 0 {lib => python}/damask/solver/abaqus.py | 0 {lib => python}/damask/solver/marc.py | 0 {lib => python}/damask/solver/solver.py | 0 {lib => python}/damask/solver/spectral.py | 0 {lib => python}/damask/test/__init__.py | 0 {lib => python}/damask/test/test.py | 0 {lib => python}/damask/util.py | 0 25 files changed, 4 insertions(+), 4 deletions(-) rename {lib => python}/damask/.gitignore (100%) rename {lib => python}/damask/__init__.py (100%) rename {lib => python}/damask/asciitable.py (100%) rename {lib => python}/damask/colormaps.py (100%) rename {lib => python}/damask/config/__init__.py (100%) rename {lib => python}/damask/config/material.py (100%) rename {lib => python}/damask/environment.py (100%) rename {lib => python}/damask/geometry/__init__.py (100%) rename {lib => python}/damask/geometry/geometry.py (100%) rename {lib => python}/damask/geometry/marc.py (100%) rename {lib => python}/damask/geometry/spectral.py (100%) rename {lib => python}/damask/orientation.py (100%) rename {lib => python}/damask/result.py (100%) rename {lib => python}/damask/result/marc2vtk.py (100%) rename {lib => python}/damask/solver/__init__.py (100%) rename {lib => python}/damask/solver/abaqus.py (100%) rename {lib => python}/damask/solver/marc.py (100%) rename {lib => python}/damask/solver/solver.py (100%) rename {lib => python}/damask/solver/spectral.py (100%) rename {lib => python}/damask/test/__init__.py (100%) rename {lib => python}/damask/test/test.py (100%) rename {lib => python}/damask/util.py (100%) diff --git a/env/DAMASK.csh b/env/DAMASK.csh index 6b6c58d9d..1819dd305 100644 --- a/env/DAMASK.csh +++ b/env/DAMASK.csh @@ -64,7 +64,7 @@ endif setenv DAMASK_NUM_THREADS $DAMASK_NUM_THREADS if ( ! $?PYTHONPATH ) then - setenv PYTHONPATH $DAMASK_ROOT/lib + setenv PYTHONPATH $DAMASK_ROOT/python else - setenv PYTHONPATH $DAMASK_ROOT/lib:$PYTHONPATH + setenv PYTHONPATH $DAMASK_ROOT/python:$PYTHONPATH endif diff --git a/env/DAMASK.sh b/env/DAMASK.sh index bd26a3ebb..fa2c8db25 100644 --- a/env/DAMASK.sh +++ b/env/DAMASK.sh @@ -95,7 +95,7 @@ if [ ! -z "$PS1" ]; then fi export DAMASK_NUM_THREADS -export PYTHONPATH=$DAMASK_ROOT/lib:$PYTHONPATH +export PYTHONPATH=$DAMASK_ROOT/python:$PYTHONPATH for var in BASE STAT SOLVER PROCESSING FREE DAMASK_BIN BRANCH; do unset "${var}" diff --git a/env/DAMASK.zsh b/env/DAMASK.zsh index 4d5a1e47d..61b9c89f9 100644 --- a/env/DAMASK.zsh +++ b/env/DAMASK.zsh @@ -88,7 +88,7 @@ if [ ! -z "$PS1" ]; then fi export DAMASK_NUM_THREADS -export PYTHONPATH=$DAMASK_ROOT/lib:$PYTHONPATH +export PYTHONPATH=$DAMASK_ROOT/python:$PYTHONPATH for var in BASE STAT SOLVER PROCESSING FREE DAMASK_BIN BRANCH; do unset "${var}" diff --git a/lib/damask/.gitignore b/python/damask/.gitignore similarity index 100% rename from lib/damask/.gitignore rename to python/damask/.gitignore diff --git a/lib/damask/__init__.py b/python/damask/__init__.py similarity index 100% rename from lib/damask/__init__.py rename to python/damask/__init__.py diff --git a/lib/damask/asciitable.py b/python/damask/asciitable.py similarity index 100% rename from lib/damask/asciitable.py rename to python/damask/asciitable.py diff --git a/lib/damask/colormaps.py b/python/damask/colormaps.py similarity index 100% rename from lib/damask/colormaps.py rename to python/damask/colormaps.py diff --git a/lib/damask/config/__init__.py b/python/damask/config/__init__.py similarity index 100% rename from lib/damask/config/__init__.py rename to python/damask/config/__init__.py diff --git a/lib/damask/config/material.py b/python/damask/config/material.py similarity index 100% rename from lib/damask/config/material.py rename to python/damask/config/material.py diff --git a/lib/damask/environment.py b/python/damask/environment.py similarity index 100% rename from lib/damask/environment.py rename to python/damask/environment.py diff --git a/lib/damask/geometry/__init__.py b/python/damask/geometry/__init__.py similarity index 100% rename from lib/damask/geometry/__init__.py rename to python/damask/geometry/__init__.py diff --git a/lib/damask/geometry/geometry.py b/python/damask/geometry/geometry.py similarity index 100% rename from lib/damask/geometry/geometry.py rename to python/damask/geometry/geometry.py diff --git a/lib/damask/geometry/marc.py b/python/damask/geometry/marc.py similarity index 100% rename from lib/damask/geometry/marc.py rename to python/damask/geometry/marc.py diff --git a/lib/damask/geometry/spectral.py b/python/damask/geometry/spectral.py similarity index 100% rename from lib/damask/geometry/spectral.py rename to python/damask/geometry/spectral.py diff --git a/lib/damask/orientation.py b/python/damask/orientation.py similarity index 100% rename from lib/damask/orientation.py rename to python/damask/orientation.py diff --git a/lib/damask/result.py b/python/damask/result.py similarity index 100% rename from lib/damask/result.py rename to python/damask/result.py diff --git a/lib/damask/result/marc2vtk.py b/python/damask/result/marc2vtk.py similarity index 100% rename from lib/damask/result/marc2vtk.py rename to python/damask/result/marc2vtk.py diff --git a/lib/damask/solver/__init__.py b/python/damask/solver/__init__.py similarity index 100% rename from lib/damask/solver/__init__.py rename to python/damask/solver/__init__.py diff --git a/lib/damask/solver/abaqus.py b/python/damask/solver/abaqus.py similarity index 100% rename from lib/damask/solver/abaqus.py rename to python/damask/solver/abaqus.py diff --git a/lib/damask/solver/marc.py b/python/damask/solver/marc.py similarity index 100% rename from lib/damask/solver/marc.py rename to python/damask/solver/marc.py diff --git a/lib/damask/solver/solver.py b/python/damask/solver/solver.py similarity index 100% rename from lib/damask/solver/solver.py rename to python/damask/solver/solver.py diff --git a/lib/damask/solver/spectral.py b/python/damask/solver/spectral.py similarity index 100% rename from lib/damask/solver/spectral.py rename to python/damask/solver/spectral.py diff --git a/lib/damask/test/__init__.py b/python/damask/test/__init__.py similarity index 100% rename from lib/damask/test/__init__.py rename to python/damask/test/__init__.py diff --git a/lib/damask/test/test.py b/python/damask/test/test.py similarity index 100% rename from lib/damask/test/test.py rename to python/damask/test/test.py diff --git a/lib/damask/util.py b/python/damask/util.py similarity index 100% rename from lib/damask/util.py rename to python/damask/util.py From 45d11f81b08a43d022a6b2e80914c89ff9521efc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 10:55:28 +0100 Subject: [PATCH 179/372] python cleaning --- python/damask/util.py | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/python/damask/util.py b/python/damask/util.py index 5def68bf6..a88080df5 100644 --- a/python/damask/util.py +++ b/python/damask/util.py @@ -1,5 +1,5 @@ # -*- coding: UTF-8 no BOM -*- -import sys,time,random,threading,os,subprocess,shlex,time +import sys,time,random,threading,os,subprocess,shlex import numpy as np from optparse import Option @@ -144,7 +144,6 @@ def progressBar(iteration, total, prefix='', bar_length=50): prefix - Optional : prefix string (Str) bar_length - Optional : character length of bar (Int) """ - fraction = iteration / float(total) if not hasattr(progressBar, "last_fraction"): # first call to function progressBar.start_time = time.time() From 4da61a0a5c0301216ae63cf310a47869699f85db Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 5 Jan 2019 19:27:21 +0100 Subject: [PATCH 180/372] [skip ci] updated version information after successful test of v2.0.2-1277-g53bc24cc --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 2ad825361..8d5912448 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1236-g1ef82e35 +v2.0.2-1277-g53bc24cc From dc64841f159b907f491ac0eacf9095e58071750d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 23:33:18 +0100 Subject: [PATCH 181/372] mutual best practise phenopowerlaw <-> disloUCLA --- src/plastic_disloUCLA.f90 | 269 +++++++++++++++++----------------- src/plastic_phenopowerlaw.f90 | 115 +++++++-------- 2 files changed, 194 insertions(+), 190 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 9fb4c9bf7..f82f54006 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -3,8 +3,7 @@ !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author David Cereceda, Lawrence Livermore National Laboratory !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine incoprorating dislocation and twinning physics -!> @details to be done +!> @brief crystal plasticity model for bcc metals, especially Tungsten !-------------------------------------------------------------------------------------------------- module plastic_disloUCLA use prec, only: & @@ -15,7 +14,6 @@ module plastic_disloUCLA private integer(pInt), dimension(:,:), allocatable, target, public :: & plastic_disloUCLA_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & plastic_disloUCLA_output !< name of each post result output @@ -23,7 +21,8 @@ module plastic_disloUCLA kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin enum, bind(c) - enumerator :: undefined_ID, & + enumerator :: & + undefined_ID, & rho_ID, & rhoDip_ID, & shearrate_ID, & @@ -49,6 +48,8 @@ module plastic_disloUCLA minDipDistance, & CLambda, & !< Adj. parameter for distance between 2 forest dislocations atomicVolume, & + tau_Peierls, & + tau0, & !* mobility law parameters H0kp, & !< activation energy for glide [J] v0, & !< dislocation velocity prefactor [m/s] @@ -57,9 +58,7 @@ module plastic_disloUCLA B, & !< friction coefficient kink_height, & !< height of the kink pair w, & !< width of the kink pair - omega, & !< attempt frequency for kink pair nucleation - tau_Peierls, & - tau0 + omega !< attempt frequency for kink pair nucleation real(pReal), allocatable, dimension(:,:) :: & interaction_SlipSlip, & !< slip resistance from slip activity forestProjectionEdge @@ -84,21 +83,19 @@ module plastic_disloUCLA real(pReal), pointer, dimension(:,:) :: & rhoEdge, & rhoEdgeDip, & - accshear_slip, & - whole + accshear_slip end type type, private :: tDisloUCLAdependentState - real(pReal), allocatable, dimension(:,:) :: & + real(pReal), allocatable, dimension(:,:) :: & mfp, & dislocationSpacing, & threshold_stress end type tDisloUCLAdependentState type(tDisloUCLAState ), allocatable, dimension(:), private :: & - state, & - dotState - + dotState, & + state type(tDisloUCLAdependentState), allocatable, dimension(:), private :: & dependentState @@ -139,11 +136,11 @@ subroutine plastic_disloUCLA_init() phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & + material_allocatePlasticState, & PLASTICITY_DISLOUCLA_label, & PLASTICITY_DISLOUCLA_ID, & material_phase, & - plasticState, & - material_allocatePlasticState + plasticState use config, only: & MATERIAL_partPhase, & config_phase @@ -151,31 +148,34 @@ subroutine plastic_disloUCLA_init() implicit none integer(pInt) :: & + index_myFamily, index_otherFamily, & + f,j,k,o, & Ninstance, & - f,j,k,o, i, & - outputSize, & - offset_slip, index_myFamily, index_otherFamily, & - startIndex, endIndex, p, & + p, i, & + NipcMyPhase, outputSize, & sizeState, sizeDotState, & - NipcMyPhase - character(len=pStringLen) :: & - structure = '',& - extmsg = '' - character(len=65536), dimension(:), allocatable :: outputs - integer(kind(undefined_ID)) :: outputID + startIndex, endIndex + integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_DISLOUCLA_label//' init -+>>>' + integer(kind(undefined_ID)) :: & + outputID + + character(len=pStringLen) :: & + structure = '',& + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_DISLOUCLA_label//' init -+>>>' write(6,'(/,a)') ' Cereceda et al., International Journal of Plasticity 78, 2016, 242-256' write(6,'(/,a)') ' http://dx.doi.org/10.1016/j.ijplas.2015.09.002' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" Ninstance = int(count(phase_plasticity == PLASTICITY_DISLOUCLA_ID),pInt) - if (Ninstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance @@ -194,21 +194,29 @@ subroutine plastic_disloUCLA_init() associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)), & - dst => dependentState(phase_plasticityInstance(p))) + dst => dependentState(phase_plasticityInstance(p)), & + config => config_phase(p)) - structure = config_phase(p)%getString('lattice_structure') + structure = config%getString('lattice_structure') + +!-------------------------------------------------------------------------------------------------- +! optional parameters that need to be defined prm%mu = lattice_mu(p) - prm%aTolRho = config_phase(p)%getFloat('atol_rho') + prm%aTolRho = config%getFloat('atol_rho') + + ! sanity checks + if (prm%aTolRho <= 0.0_pReal) extmsg = trim(extmsg)//' atol_rho' + !-------------------------------------------------------------------------------------------------- ! slip related parameters - prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then - prm%nonSchmidCoeff = config_phase(p)%getFloats('nonschmid_coefficients',& + 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) @@ -217,32 +225,32 @@ subroutine plastic_disloUCLA_init() prm%nonSchmid_neg = prm%Schmid_slip endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - config_phase(p)%getFloats('interaction_slipslip'), & + config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%rho0 = config_phase(p)%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) - prm%rhoDip0 = config_phase(p)%getFloats('rhoedgedip0', requiredShape=shape(prm%Nslip)) - prm%v0 = config_phase(p)%getFloats('v0', requiredShape=shape(prm%Nslip)) - prm%burgers = config_phase(p)%getFloats('slipburgers', requiredShape=shape(prm%Nslip)) - prm%H0kp = config_phase(p)%getFloats('qedge', requiredShape=shape(prm%Nslip)) + prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) + prm%rhoDip0 = config%getFloats('rhoedgedip0', requiredShape=shape(prm%Nslip)) + prm%v0 = config%getFloats('v0', requiredShape=shape(prm%Nslip)) + prm%burgers = config%getFloats('slipburgers', requiredShape=shape(prm%Nslip)) + prm%H0kp = config%getFloats('qedge', requiredShape=shape(prm%Nslip)) - prm%clambda = config_phase(p)%getFloats('clambdaslip', requiredShape=shape(prm%Nslip)) - prm%tau_Peierls = config_phase(p)%getFloats('tau_peierls', requiredShape=shape(prm%Nslip)) ! ToDo: Deprecated - prm%p = config_phase(p)%getFloats('p_slip', requiredShape=shape(prm%Nslip), & - defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) - prm%q = config_phase(p)%getFloats('q_slip', requiredShape=shape(prm%Nslip), & - defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) - prm%kink_height = config_phase(p)%getFloats('kink_height', requiredShape=shape(prm%Nslip)) - prm%w = config_phase(p)%getFloats('kink_width', requiredShape=shape(prm%Nslip)) - prm%omega = config_phase(p)%getFloats('omega', requiredShape=shape(prm%Nslip)) - prm%B = config_phase(p)%getFloats('friction_coeff', requiredShape=shape(prm%Nslip)) + prm%clambda = config%getFloats('clambdaslip', requiredShape=shape(prm%Nslip)) + prm%tau_Peierls = config%getFloats('tau_peierls', requiredShape=shape(prm%Nslip)) ! ToDo: Deprecated + prm%p = config%getFloats('p_slip', requiredShape=shape(prm%Nslip), & + defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) + prm%q = config%getFloats('q_slip', requiredShape=shape(prm%Nslip), & + defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) + prm%kink_height = config%getFloats('kink_height', requiredShape=shape(prm%Nslip)) + prm%w = config%getFloats('kink_width', requiredShape=shape(prm%Nslip)) + prm%omega = config%getFloats('omega', requiredShape=shape(prm%Nslip)) + prm%B = config%getFloats('friction_coeff', requiredShape=shape(prm%Nslip)) - prm%SolidSolutionStrength = config_phase(p)%getFloat('solidsolutionstrength') ! ToDo: Deprecated - prm%grainSize = config_phase(p)%getFloat('grainsize') - prm%D0 = config_phase(p)%getFloat('d0') - prm%Qsd = config_phase(p)%getFloat('qsd') - prm%atomicVolume = config_phase(p)%getFloat('catomicvolume') * prm%burgers**3.0_pReal - prm%minDipDistance = config_phase(p)%getFloat('cedgedipmindistance') * prm%burgers - prm%dipoleformation = config_phase(p)%getFloat('dipoleformationfactor') > 0.0_pReal !should be on by default + prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') ! ToDo: Deprecated + prm%grainSize = config%getFloat('grainsize') + prm%D0 = config%getFloat('d0') + prm%Qsd = config%getFloat('qsd') + prm%atomicVolume = config%getFloat('catomicvolume') * prm%burgers**3.0_pReal + prm%minDipDistance = config%getFloat('cedgedipmindistance') * prm%burgers + prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_pReal !should be on by default, ToDo: change to /key/-key ! expand: family => system prm%rho0 = math_expand(prm%rho0, prm%Nslip) @@ -262,44 +270,38 @@ subroutine plastic_disloUCLA_init() prm%minDipDistance = math_expand(prm%minDipDistance, prm%Nslip) prm%tau0 = prm%tau_peierls + prm%SolidSolutionStrength - ! sanity checks - if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0' - if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0' - if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//' v0' - if (any(prm%burgers <= 0.0_pReal)) extmsg = trim(extmsg)//' slipburgers' - if (any(prm%H0kp <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge' - if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' - - if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' d0' - if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' qsd' + if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0' + if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0' + if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//' v0' + if (any(prm%burgers <= 0.0_pReal)) extmsg = trim(extmsg)//' slipburgers' + if (any(prm%H0kp <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge' + if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' + if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' d0' + if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' qsd' !if (plastic_disloUCLA_CAtomicVolume(instance) <= 0.0_pReal) & ! call IO_error(211_pInt,el=instance,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOUCLA_label//')') - - ! if (plastic_disloUCLA_aTolRho(instance) <= 0.0_pReal) & - ! call IO_error(211_pInt,el=instance,ext_msg='aTolRho ('//PLASTICITY_DISLOUCLA_label//')') - else slipActive allocate(prm%rho0(0)) allocate(prm%rhoDip0(0)) endif slipActive +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//PLASTICITY_DISLOUCLA_label//')') -#if defined(__GFORTRAN__) - outputs = ['GfortranBug86277'] - outputs = config_phase(p)%getStrings('(output)',defaultVal=outputs) - if (outputs(1) == 'GfortranBug86277') outputs = emptyStringArray -#else - outputs = config_phase(p)%getStrings('(output)',defaultVal=emptyStringArray) -#endif +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - - do i = 1_pInt, size(outputs) + do i=1_pInt, size(outputs) outputID = undefined_ID outputSize = prm%totalNslip select case(trim(outputs(i))) + case ('edge_density') outputID = merge(rho_ID,undefined_ID,prm%totalNslip>0_pInt) case ('dipole_density') @@ -314,6 +316,7 @@ subroutine plastic_disloUCLA_init() outputID = merge(thresholdstress_ID,undefined_ID,prm%totalNslip>0_pInt) case ('edge_dipole_distance') outputID = merge(dipoleDistance_ID,undefined_ID,prm%totalNslip>0_pInt) + end select if (outputID /= undefined_ID) then @@ -322,19 +325,16 @@ subroutine plastic_disloUCLA_init() prm%outputID = [prm%outputID, outputID] endif - enddo - - NipcMyPhase=count(material_phase==p) + end do !-------------------------------------------------------------------------------------------------- ! allocate state arrays - + NipcMyPhase = count(material_phase==p) sizeDotState = int(size(['rhoEdge ','rhoEdgeDip ','accshearslip']),pInt) * prm%totalNslip - sizeState = sizeDotState + sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & prm%totalNslip,0_pInt,0_pInt) - plasticState(p)%sizePostResults = sum(plastic_disloUCLA_sizePostResult(:,phase_plasticityInstance(p))) allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) @@ -353,43 +353,41 @@ subroutine plastic_disloUCLA_init() lattice_st(:,sum(lattice_NslipSystem(1:o-1,p))+k,p))) enddo; enddo enddo slipSystemsLoop - enddo mySlipFamilies + enddo mySlipFamilies - offset_slip = 2_pInt*plasticState(p)%nSlip - plasticState(p)%slipRate => & - plasticState(p)%dotState(offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) - plasticState(p)%accumulatedSlip => & - plasticState(p)%state (offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) - - startIndex=1_pInt - endIndex=prm%totalNslip +!-------------------------------------------------------------------------------------------------- +! locally defined state aliases and initialization of state0 and aTolState + startIndex = 1_pInt + endIndex = prm%totalNslip stt%rhoEdge=>plasticState(p)%state(startIndex:endIndex,:) stt%rhoEdge= spread(prm%rho0,2,NipcMyPhase) dot%rhoEdge=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolRho - startIndex=endIndex+1_pInt - endIndex=endIndex+prm%totalNslip + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip stt%rhoEdgeDip=>plasticState(p)%state(startIndex:endIndex,:) stt%rhoEdgeDip= spread(prm%rhoDip0,2,NipcMyPhase) dot%rhoEdgeDip=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolRho - startIndex=endIndex+1_pInt - endIndex=endIndex+prm%totalNslip + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip stt%accshear_slip=>plasticState(p)%state(startIndex:endIndex,:) dot%accshear_slip=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = 1e6_pReal + ! global alias + plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) + plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) - dot%whole => plasticState(p)%dotState - - - allocate(dst%mfp(prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(dst%mfp(prm%totalNslip,NipcMyPhase), source=0.0_pReal) allocate(dst%dislocationSpacing(prm%totalNslip,NipcMyPhase),source=0.0_pReal) - allocate(dst%threshold_stress(prm%totalNslip,NipcMyPhase),source=0.0_pReal) + allocate(dst%threshold_stress(prm%totalNslip,NipcMyPhase), source=0.0_pReal) plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + end associate + enddo end subroutine plastic_disloUCLA_init @@ -432,28 +430,30 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst implicit none real(pReal), dimension(3,3), intent(out) :: & - Lp + Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & - dLp_dMp - - real(pReal), dimension(3,3), intent(in):: & + dLp_dMp !< derivative of Lp with respect to the Mandel stress + + real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & temperature !< temperature - integer(pInt), intent(in) :: & - instance, of + integer(pInt), intent(in) :: & + instance, & + of - integer(pInt) :: i,k,l,m,n + integer(pInt) :: & + i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg - - associate(prm => param(instance)) + dgdot_dtauslip_pos,dgdot_dtauslip_neg, & + gdot_slip_pos,gdot_slip_neg Lp = 0.0_pReal dLp_dMp = 0.0_pReal + + associate(prm => param(instance)) - call kinetics(Mp,Temperature,instance,of, & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) + call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) slipSystems: do i = 1_pInt, 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) & @@ -501,7 +501,6 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) gdot_slip_pos,gdot_slip_neg, & tau_slip_pos1 = tau_slip_pos,tau_slip_neg1 = tau_slip_neg) - dot%whole(:,of) = 0.0_pReal dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) ! ToDo: needs to be abs VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) @@ -539,7 +538,7 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe use prec, only: & dEq, dNeq0 use math, only: & - pi, & + PI, & math_mul33xx33 implicit none @@ -557,14 +556,12 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe integer(pInt) :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos, & - gdot_slip_neg + gdot_slip_pos,gdot_slip_neg + + c = 0_pInt associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) - postResults = 0.0_pReal - c = 0_pInt - outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) @@ -591,14 +588,18 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe endif postResults(c+i)=min(postResults(c+i),dst%mfp(i,of)) enddo + end select c = c + prm%totalNslip + enddo outputsLoop + end associate end function plastic_disloUCLA_postResults + !-------------------------------------------------------------------------------------------------- !> @brief Shear rates on slip systems, their derivatives with respect to resolved stress and the ! resolved stresss @@ -618,23 +619,27 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pReal), intent(in) :: & temperature !< temperature - integer(pInt), intent(in) :: & - of, instance + integer(pInt), intent(in) :: & + instance, & + of - integer(pInt) :: & - j - real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg - real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & - dgdot_dtauslip_pos,tau_slip_pos1,dgdot_dtauslip_neg,tau_slip_neg1 + real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & + gdot_slip_pos, & + gdot_slip_neg + real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & + dgdot_dtauslip_pos, & + dgdot_dtauslip_neg, & + tau_slip_pos1, & + tau_slip_neg1 real(pReal), dimension(param(instance)%totalNslip) :: & StressRatio, & StressRatio_p,StressRatio_pminus1, & dvel_slip, vel_slip, & tau_slip_pos,tau_slip_neg, & needsGoodName ! ToDo: @Karo: any idea? + integer(pInt) :: j associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 1e42876f9..bc2557503 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -2,12 +2,11 @@ !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for phenomenological crystal plasticity formulation using a powerlaw -!! fitting +!> @brief phenomenological crystal plasticity formulation using a powerlaw fitting !-------------------------------------------------------------------------------------------------- module plastic_phenopowerlaw use prec, only: & - pReal,& + pReal, & pInt implicit none @@ -100,7 +99,6 @@ module plastic_phenopowerlaw contains - !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks @@ -194,9 +192,9 @@ subroutine plastic_phenopowerlaw_init prm%aTolTwinfrac = config%getFloat('atol_twinfrac', defaultVal=1.0e-6_pReal) ! sanity checks - if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//'aTolresistance ' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//'aTolShear ' - if (prm%aTolTwinfrac <= 0.0_pReal) extmsg = trim(extmsg)//'atoltwinfrac ' + if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//' aTolresistance' + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' + if (prm%aTolTwinfrac <= 0.0_pReal) extmsg = trim(extmsg)//' atoltwinfrac' !-------------------------------------------------------------------------------------------------- ! slip related parameters @@ -234,11 +232,11 @@ subroutine plastic_phenopowerlaw_init prm%H_int = math_expand(prm%H_int, prm%Nslip) ! sanity checks - if (prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//'gdot0_slip ' - if (prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//'a_slip ' - if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//'n_slip ' - if (any(prm%xi_slip_0 <= 0.0_pReal)) extmsg = trim(extmsg)//'xi_slip_0 ' - if (any(prm%xi_slip_sat < prm%xi_slip_0)) extmsg = trim(extmsg)//'xi_slip_sat ' + if (prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0_slip' + if (prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//' a_slip' + if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if (any(prm%xi_slip_0 <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_slip_0' + if (any(prm%xi_slip_sat < prm%xi_slip_0)) extmsg = trim(extmsg)//' xi_slip_sat' else slipActive allocate(prm%interaction_SlipSlip(0,0)) allocate(prm%xi_slip_0(0)) @@ -268,8 +266,8 @@ subroutine plastic_phenopowerlaw_init prm%xi_twin_0 = math_expand(prm%xi_twin_0, prm%Ntwin) ! sanity checks - if (prm%gdot0_twin <= 0.0_pReal) extmsg = trim(extmsg)//'gdot0_twin ' - if (prm%n_twin <= 0.0_pReal) extmsg = trim(extmsg)//'n_twin ' + if (prm%gdot0_twin <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0_twin' + if (prm%n_twin <= 0.0_pReal) extmsg = trim(extmsg)//' n_twin' else twinActive allocate(prm%interaction_TwinTwin(0,0)) allocate(prm%xi_twin_0(0)) @@ -303,48 +301,49 @@ subroutine plastic_phenopowerlaw_init do i=1_pInt, size(outputs) outputID = undefined_ID select case(outputs(i)) - case ('resistance_slip') - outputID = merge(resistance_slip_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip - case ('accumulatedshear_slip') - outputID = merge(accumulatedshear_slip_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip - case ('shearrate_slip') - outputID = merge(shearrate_slip_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip - case ('resolvedstress_slip') - outputID = merge(resolvedstress_slip_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip - case ('resistance_twin') - outputID = merge(resistance_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) - outputSize = prm%totalNtwin - case ('accumulatedshear_twin') - outputID = merge(accumulatedshear_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) - outputSize = prm%totalNtwin - case ('shearrate_twin') - outputID = merge(shearrate_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) - outputSize = prm%totalNtwin - case ('resolvedstress_twin') - outputID = merge(resolvedstress_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) - outputSize = prm%totalNtwin + case ('resistance_slip') + outputID = merge(resistance_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('accumulatedshear_slip') + outputID = merge(accumulatedshear_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('shearrate_slip') + outputID = merge(shearrate_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip + case ('resolvedstress_slip') + outputID = merge(resolvedstress_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputSize = prm%totalNslip - end select + case ('resistance_twin') + outputID = merge(resistance_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputSize = prm%totalNtwin + case ('accumulatedshear_twin') + outputID = merge(accumulatedshear_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputSize = prm%totalNtwin + case ('shearrate_twin') + outputID = merge(shearrate_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputSize = prm%totalNtwin + case ('resolvedstress_twin') + outputID = merge(resolvedstress_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputSize = prm%totalNtwin - if (outputID /= undefined_ID) then - plastic_phenopowerlaw_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_phenopowerlaw_sizePostResult(i,phase_plasticityInstance(p)) = outputSize - prm%outputID = [prm%outputID , outputID] - endif + end select + + if (outputID /= undefined_ID) then + plastic_phenopowerlaw_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_phenopowerlaw_sizePostResult(i,phase_plasticityInstance(p)) = outputSize + prm%outputID = [prm%outputID, outputID] + endif end do !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - sizeState = size(['tau_slip ','gamma_slip']) * prm%TotalNslip & - + size(['tau_twin ','gamma_twin']) * prm%TotalNtwin - sizeDotState = sizeState + sizeDotState = size(['tau_slip ','gamma_slip']) * prm%TotalNslip & + + size(['tau_twin ','gamma_twin']) * prm%TotalNtwin + sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & prm%totalNslip,prm%totalNtwin,0_pInt) @@ -384,6 +383,7 @@ subroutine plastic_phenopowerlaw_init plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate + enddo end subroutine plastic_phenopowerlaw_init @@ -394,7 +394,7 @@ end subroutine plastic_phenopowerlaw_init !> @details asumme that deformation by dislocation glide affects twinned and untwinned volume ! equally (Taylor assumption). Twinning happens only in untwinned volume ( !-------------------------------------------------------------------------------------------------- -subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) +pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(out) :: & @@ -515,14 +515,14 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) math_mul33xx33 implicit none - real(pReal), dimension(3,3), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer(pInt), intent(in) :: & instance, & of real(pReal), dimension(sum(plastic_phenopowerlaw_sizePostResult(:,instance))) :: & - postResults + postResults integer(pInt) :: & o,c,i @@ -530,8 +530,8 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) gdot_slip_pos,gdot_slip_neg c = 0_pInt - - associate( prm => param(instance), stt => state(instance)) + + associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) @@ -569,7 +569,7 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) end select enddo outputsLoop - + end associate end function plastic_phenopowerlaw_postResults @@ -584,7 +584,7 @@ end function plastic_phenopowerlaw_postResults pure subroutine kinetics_slip(Mp,instance,of, & gdot_slip_pos,gdot_slip_neg,dgdot_dtau_slip_pos,dgdot_dtau_slip_neg) use prec, only: & - dNeq0 + dNeq0 use math, only: & math_mul33xx33 @@ -595,13 +595,12 @@ pure subroutine kinetics_slip(Mp,instance,of, & instance, & of - real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & + real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & gdot_slip_pos, & gdot_slip_neg - real(pReal), dimension(param(instance)%totalNslip), intent(out), optional :: & + real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & dgdot_dtau_slip_pos, & dgdot_dtau_slip_neg - real(pReal), dimension(param(instance)%totalNslip) :: & tau_slip_pos, & tau_slip_neg From 77a0cfd7a21b6844cf4a96d1ad149a57b4c7ee8d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 23:41:13 +0100 Subject: [PATCH 182/372] also adjusted plastic_isotropic --- src/plastic_isotropic.f90 | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index a44681676..0e2530abd 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -9,7 +9,7 @@ !-------------------------------------------------------------------------------------------------- module plastic_isotropic use prec, only: & - pReal,& + pReal, & pInt implicit none @@ -71,7 +71,6 @@ module plastic_isotropic contains - !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks @@ -122,7 +121,7 @@ subroutine plastic_isotropic_init() sizeState, sizeDotState character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - + integer(kind(undefined_ID)) :: & outputID @@ -204,16 +203,18 @@ subroutine plastic_isotropic_init() do i=1_pInt, 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_pInt - prm%outputID = [prm%outputID , outputID] + plastic_isotropic_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_isotropic_sizePostResult(i,phase_plasticityInstance(p)) = 1_pInt + prm%outputID = [prm%outputID, outputID] endif end do @@ -221,8 +222,8 @@ subroutine plastic_isotropic_init() !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - sizeState = size(["flowstress ","accumulated_shear"]) - sizeDotState = sizeState + sizeDotState = size(['flowstress ','accumulated_shear']) + sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & 1_pInt,0_pInt,0_pInt) @@ -243,8 +244,8 @@ subroutine plastic_isotropic_init() plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,1:NipcMyPhase) plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally - - end associate + + end associate enddo @@ -319,7 +320,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) end if end associate - + end subroutine plastic_isotropic_LpAndItsTangent @@ -373,9 +374,9 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) Li = 0.0_pReal dLi_dTstar = 0.0_pReal endif - + end associate - + end subroutine plastic_isotropic_LiAndItsTangent @@ -471,6 +472,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) + case (flowstress_ID) postResults(c+1_pInt) = stt%flowstress(of) c = c + 1_pInt @@ -478,6 +480,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) postResults(c+1_pInt) = prm%gdot0 & * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n c = c + 1_pInt + end select enddo outputsLoop From 19df6f8a71d59c285a24655ef75ac5a3b486db09 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 5 Jan 2019 23:55:10 +0100 Subject: [PATCH 183/372] general polishing --- src/config.f90 | 18 +++++------ src/plastic_disloUCLA.f90 | 4 +-- src/plastic_isotropic.f90 | 6 ++-- src/plastic_none.f90 | 56 ++++++++++++++--------------------- src/plastic_phenopowerlaw.f90 | 4 +-- 5 files changed, 38 insertions(+), 50 deletions(-) diff --git a/src/config.f90 b/src/config.f90 index c7fd95b43..dcc14e015 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -318,7 +318,7 @@ subroutine show(this) do while (associated(item%next)) write(6,'(a)') ' '//trim(item%string%val) item => item%next - end do + enddo end subroutine show @@ -391,7 +391,7 @@ logical function keyExists(this,key) do while (associated(item%next) .and. .not. keyExists) keyExists = trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key) item => item%next - end do + enddo end function keyExists @@ -417,7 +417,7 @@ integer(pInt) function countKeys(this,key) if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) & countKeys = countKeys + 1_pInt item => item%next - end do + enddo end function countKeys @@ -451,7 +451,7 @@ real(pReal) function getFloat(this,key,defaultVal) getFloat = IO_FloatValue(item%string%val,item%string%pos,2) endif item => item%next - end do + enddo if (.not. found) call IO_error(140_pInt,ext_msg=key) @@ -487,7 +487,7 @@ integer(pInt) function getInt(this,key,defaultVal) getInt = IO_IntValue(item%string%val,item%string%pos,2) endif item => item%next - end do + enddo if (.not. found) call IO_error(140_pInt,ext_msg=key) @@ -538,7 +538,7 @@ character(len=65536) function getString(this,key,defaultVal,raw) endif endif item => item%next - end do + enddo if (.not. found) call IO_error(140_pInt,ext_msg=key) @@ -584,7 +584,7 @@ function getFloats(this,key,defaultVal,requiredShape,requiredSize) enddo endif item => item%next - end do + enddo if (.not. found) then if (present(defaultVal)) then; getFloats = defaultVal; else; call IO_error(140_pInt,ext_msg=key); endif @@ -635,7 +635,7 @@ function getInts(this,key,defaultVal,requiredShape,requiredSize) enddo endif item => item%next - end do + enddo if (.not. found) then if (present(defaultVal)) then; getInts = defaultVal; else; call IO_error(140_pInt,ext_msg=key); endif @@ -712,7 +712,7 @@ function getStrings(this,key,defaultVal,requiredShape,raw) endif notAllocated endif item => item%next - end do + enddo if (.not. found) then if (present(defaultVal)) then; getStrings = defaultVal; else; call IO_error(140_pInt,ext_msg=key); endif diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index f82f54006..67adb083b 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -189,7 +189,7 @@ subroutine plastic_disloUCLA_init() allocate(dependentState(Ninstance)) - do p = 1_pInt, size(phase_plasticityInstance) + do p = 1_pInt, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_DISLOUCLA_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -325,7 +325,7 @@ subroutine plastic_disloUCLA_init() prm%outputID = [prm%outputID, outputID] endif - end do + enddo !-------------------------------------------------------------------------------------------------- ! allocate state arrays diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 0e2530abd..c7d92651a 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -91,7 +91,7 @@ subroutine plastic_isotropic_init() debug_levelExtensive, & #endif debug_level, & - debug_constitutive,& + debug_constitutive, & debug_levelBasic use IO, only: & IO_error, & @@ -148,7 +148,7 @@ subroutine plastic_isotropic_init() allocate(state(Ninstance)) allocate(dotState(Ninstance)) - do p = 1_pInt, size(phase_plasticityInstance) + do p = 1_pInt, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -217,7 +217,7 @@ subroutine plastic_isotropic_init() prm%outputID = [prm%outputID, outputID] endif - end do + enddo !-------------------------------------------------------------------------------------------------- ! allocate state arrays diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index 5b5bb49d1..2c6ca6e93 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -1,7 +1,8 @@ !-------------------------------------------------------------------------------------------------- !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH -!> @brief material subroutine for purely elastic material +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Dummy plasticity for purely elastic material !-------------------------------------------------------------------------------------------------- module plastic_none @@ -13,7 +14,6 @@ module plastic_none contains - !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks @@ -32,52 +32,40 @@ subroutine plastic_none_init debug_levelBasic use IO, only: & IO_timeStamp - use numerics, only: & - numerics_integrator use material, only: & phase_plasticity, & + material_allocatePlasticState, & PLASTICITY_NONE_label, & + PLASTICITY_NONE_ID, & material_phase, & - plasticState, & - PLASTICITY_none_ID + plasticState implicit none - integer(pInt) :: & - maxNinstance, & - phase, & - NofMyPhase - + Ninstance, & + p, & + NipcMyPhase + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - - maxNinstance = int(count(phase_plasticity == PLASTICITY_none_ID),pInt) + + Ninstance = int(count(phase_plasticity == PLASTICITY_NONE_ID),pInt) if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - initializeInstances: do phase = 1_pInt, size(phase_plasticity) - if (phase_plasticity(phase) == PLASTICITY_none_ID) then - NofMyPhase=count(material_phase==phase) + do p = 1_pInt, size(phase_plasticity) + if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle - allocate(plasticState(phase)%aTolState (0_pInt)) - allocate(plasticState(phase)%state0 (0_pInt,NofMyPhase)) - allocate(plasticState(phase)%partionedState0 (0_pInt,NofMyPhase)) - allocate(plasticState(phase)%subState0 (0_pInt,NofMyPhase)) - allocate(plasticState(phase)%state (0_pInt,NofMyPhase)) +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + NipcMyPhase = count(material_phase == p) - allocate(plasticState(phase)%dotState (0_pInt,NofMyPhase)) - allocate(plasticState(phase)%deltaState (0_pInt,NofMyPhase)) - if (any(numerics_integrator == 1_pInt)) then - allocate(plasticState(phase)%previousDotState (0_pInt,NofMyPhase)) - allocate(plasticState(phase)%previousDotState2(0_pInt,NofMyPhase)) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(plasticState(phase)%RK4dotState (0_pInt,NofMyPhase)) - if (any(numerics_integrator == 5_pInt)) & - allocate(plasticState(phase)%RKCK45dotState (6,0_pInt,NofMyPhase)) - endif - enddo initializeInstances + call material_allocatePlasticState(p,NipcMyPhase,0_pInt,0_pInt,0_pInt, & + 0_pInt,0_pInt,0_pInt) + plasticState(p)%sizePostResults = 0_pInt + + enddo end subroutine plastic_none_init diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index bc2557503..82050086e 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -171,7 +171,7 @@ subroutine plastic_phenopowerlaw_init allocate(state(Ninstance)) allocate(dotState(Ninstance)) - do p = 1_pInt, size(phase_plasticityInstance) + do p = 1_pInt, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_PHENOPOWERLAW_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -336,7 +336,7 @@ subroutine plastic_phenopowerlaw_init prm%outputID = [prm%outputID, outputID] endif - end do + enddo !-------------------------------------------------------------------------------------------------- ! allocate state arrays From 8277e960c081c62cd9d8fd7aa44edb47be8e35be Mon Sep 17 00:00:00 2001 From: Test User Date: Sun, 6 Jan 2019 15:07:50 +0100 Subject: [PATCH 184/372] [skip ci] updated version information after successful test of v2.0.2-1291-g19df6f8a --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 8d5912448..6efd0b994 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1277-g53bc24cc +v2.0.2-1291-g19df6f8a From ebf028421b9968400a17727f56381358ff0c6c5e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 6 Jan 2019 20:57:40 +0100 Subject: [PATCH 185/372] corrected unit --- src/plastic_phenopowerlaw.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 5df23da94..0fe63737e 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -595,7 +595,7 @@ subroutine plastic_phenopowerlaw_results(instance,group) case (resistance_slip_ID) call results_writeVectorDataset(group,stt%xi_slip,'xi_slip','Pa') case (accumulatedshear_slip_ID) - call results_writeVectorDataset(group,stt%gamma_slip,'gamma_slip','1/s') + call results_writeVectorDataset(group,stt%gamma_slip,'gamma_slip','-') end select enddo outputsLoop end associate From 15d1789a195d5bdfcff5f2f10d69993c179023d4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 6 Jan 2019 21:18:35 +0100 Subject: [PATCH 186/372] following best practise from phenopowerlaw --- src/plastic_kinematichardening.f90 | 341 +++++++++++++---------------- src/plastic_phenopowerlaw.f90 | 13 +- 2 files changed, 164 insertions(+), 190 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index b30131535..20a09c7e9 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -3,52 +3,41 @@ !> @author Zhuowen Zhao, Michigan State University !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief Phenomenological crystal plasticity using a power law formulation for the shear rates -!! and a Voce-type kinematic hardening rule +!! and a Voce-type kinematic hardening rule !-------------------------------------------------------------------------------------------------- module plastic_kinehardening use prec, only: & pReal,& pInt - + implicit none private integer(pInt), dimension(:,:), allocatable, target, public :: & plastic_kinehardening_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & plastic_kinehardening_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - plastic_kinehardening_Noutput !< number of outputs per instance - - - - integer(pInt), dimension(:,:), allocatable, private :: & - plastic_kinehardening_Nslip !< active number of slip systems per family (input parameter, per family) - enum, bind(c) enumerator :: & undefined_ID, & - crss_ID, & !< critical resolved stress - crss_back_ID, & !< critical resolved back stress - sense_ID, & !< sense of acting shear stress (-1 or +1) - chi0_ID, & !< backstress at last switch of stress sense (positive?) - gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) + crss_ID, & !< critical resolved stress + crss_back_ID, & !< critical resolved back stress + sense_ID, & !< sense of acting shear stress (-1 or +1) + chi0_ID, & !< backstress at last switch of stress sense (positive?) + gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) accshear_ID, & shearrate_ID, & resolvedstress_ID end enum - - type, private :: tParameters !< container type for internal constitutive parameters + type, private :: tParameters real(pReal) :: & gdot0, & !< reference shear strain rate for slip (input parameter) n_slip, & !< stress exponent for slip (input parameter) aTolResistance, & aTolShear - real(pReal), dimension(:), allocatable, private :: & - crss0, & !< initial critical shear stress for slip (input parameter, per family) + real(pReal), allocatable, dimension(:) :: & + crss0, & !< initial critical shear stress for slip (input parameter, per family) theta0, & !< initial hardening rate of forward stress for each slip theta1, & !< asymptotic hardening rate of forward stress for each slip > theta0_b, & !< initial hardening rate of back stress for each slip > @@ -56,8 +45,8 @@ module plastic_kinehardening tau1, & tau1_b, & nonSchmidCoeff - real(pReal), dimension(:,:), allocatable, private :: & - interaction_slipslip !< latent hardening matrix + real(pReal), allocatable, dimension(:,:) :: & + interaction_slipslip !< slip resistance from slip activity real(pReal), allocatable, dimension(:,:,:) :: & Schmid_slip, & Schmid_twin, & @@ -72,6 +61,8 @@ module plastic_kinehardening outputID !< ID of each post result output end type + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + type, private :: tKinehardeningState real(pReal), pointer, dimension(:,:) :: & !< vectors along NipcMyInstance crss, & !< critical resolved stress @@ -80,18 +71,13 @@ module plastic_kinehardening chi0, & !< backstress at last switch of stress sense gamma0, & !< accumulated shear at last switch of stress sense accshear !< accumulated (absolute) shear - end type - type(tParameters), dimension(:), allocatable, private :: & - param !< containers of constitutive parameters (len Ninstance) - type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & deltaState, & state - public :: & plastic_kinehardening_init, & plastic_kinehardening_LpAndItsTangent, & @@ -105,15 +91,19 @@ module plastic_kinehardening contains - !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_init - use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) +#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 + use, intrinsic :: iso_fortran_env, only: & + compiler_version, & + compiler_options +#endif use prec, only: & - dEq0 + dEq0, & + pStringLen use debug, only: & #ifdef DEBUG debug_e, & @@ -142,68 +132,55 @@ subroutine plastic_kinehardening_init material_phase, & plasticState use config, only: & - config_phase, & - MATERIAL_partPhase + MATERIAL_partPhase, & + config_phase use lattice implicit none - - integer(kind(undefined_ID)) :: & - output_ID integer(pInt) :: & - o, i, p, & - instance, & Ninstance, & - NipcMyPhase, & - outputSize, & - offset_slip, & - startIndex, endIndex, & - sizeDotState, & - sizeState, & - sizeDeltaState + p, i, o, & + NipcMyPhase, outputSize, & + sizeState, sizeDeltaState, sizeDotState, & + startIndex, endIndex integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & - outputID !< ID of each post result output - - character(len=65536), dimension(:), allocatable :: & - outputs - character(len=65536) :: & - extmsg = '', & - structure = '' + outputID - write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_KINEHARDENING_label//' init -+>>>' + character(len=pStringLen) :: & + structure = '',& + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_KINEHARDENING_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" Ninstance = int(count(phase_plasticity == PLASTICITY_KINEHARDENING_ID),pInt) - if (Ninstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a,1x,i5,/)') '# instances:',Ninstance - - allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),Ninstance), & - source=0_pInt) + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) allocate(plastic_kinehardening_output(maxval(phase_Noutput),Ninstance)) - plastic_kinehardening_output = '' - allocate(plastic_kinehardening_Noutput(Ninstance), source=0_pInt) - allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,Ninstance), source=0_pInt) - - allocate(param(Ninstance)) ! one container of parameters per instance + plastic_kinehardening_output = '' + + allocate(param(Ninstance)) allocate(state(Ninstance)) allocate(dotState(Ninstance)) allocate(deltaState(Ninstance)) - + do p = 1_pInt, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle - instance = phase_plasticityInstance(p) ! which instance of my phase associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & delta => deltaState(phase_plasticityInstance(p)), & - stt => state(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 @@ -211,11 +188,12 @@ subroutine plastic_kinehardening_init endif #endif - structure = config_phase(p)%getString('lattice_structure') + structure = config%getString('lattice_structure') + !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined - prm%aTolResistance = config_phase(p)%getFloat('atol_resistance',defaultVal=1.0_pReal) - prm%aTolShear = config_phase(p)%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + prm%aTolResistance = config%getFloat('atol_resistance',defaultVal=1.0_pReal) + prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) ! sanity checks if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//'aTolresistance ' @@ -223,13 +201,13 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! slip related parameters - prm%Nslip = config_phase(p)%getInts('nslip',defaultVal=emptyIntArray) + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal)) + config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then - prm%nonSchmidCoeff = config_phase(p)%getFloats('nonschmid_coefficients',& + 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) @@ -238,16 +216,16 @@ subroutine plastic_kinehardening_init prm%nonSchmid_neg = prm%Schmid_slip endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - config_phase(p)%getFloats('interaction_slipslip'), & + config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%crss0 = config_phase(p)%getFloats('crss0', requiredShape=shape(prm%Nslip)) - prm%tau1 = config_phase(p)%getFloats('tau1', requiredShape=shape(prm%Nslip)) - prm%tau1_b = config_phase(p)%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) - prm%theta0 = config_phase(p)%getFloats('theta0', requiredShape=shape(prm%Nslip)) - prm%theta1 = config_phase(p)%getFloats('theta1', requiredShape=shape(prm%Nslip)) - prm%theta0_b = config_phase(p)%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) - prm%theta1_b = config_phase(p)%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + prm%crss0 = config%getFloats('crss0', requiredShape=shape(prm%Nslip)) + prm%tau1 = config%getFloats('tau1', requiredShape=shape(prm%Nslip)) + prm%tau1_b = config%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) + prm%theta0 = config%getFloats('theta0', requiredShape=shape(prm%Nslip)) + prm%theta1 = config%getFloats('theta1', requiredShape=shape(prm%Nslip)) + prm%theta0_b = config%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) + prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) ! expand: family => system prm%crss0 = math_expand(prm%crss0, prm%Nslip) @@ -258,15 +236,27 @@ subroutine plastic_kinehardening_init prm%theta0_b = math_expand(prm%theta0_b,prm%Nslip) prm%theta1_b = math_expand(prm%theta1_b,prm%Nslip) - prm%gdot0 = config_phase(p)%getFloat('gdot0') - prm%n_slip = config_phase(p)%getFloat('n_slip') + prm%gdot0 = config%getFloat('gdot0') + prm%n_slip = config%getFloat('n_slip') + +!-------------------------------------------------------------------------------------------------- +! sanity checks + + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%crss0 (1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%tau1 (1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' + ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & + ! .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' + ! if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + ! if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' endif slipActive !-------------------------------------------------------------------------------------------------- ! output pararameters - outputs = config_phase(p)%getStrings('(output)',defaultVal=emptyStringArray) + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID @@ -299,7 +289,6 @@ subroutine plastic_kinehardening_init end select if (outputID /= undefined_ID) then - plastic_kinehardening_Noutput(instance) = plastic_kinehardening_Noutput(instance) + 1_pInt plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize prm%outputID = [prm%outputID , outputID] @@ -309,90 +298,71 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase == p) ! number of constituents with my phase + NipcMyPhase = count(material_phase == p) sizeDotState = size(['crss ','crss_back', 'accshear ']) * prm%TotalNslip sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0' ]) * prm%TotalNslip sizeState = sizeDotState + sizeDeltaState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & prm%totalNslip,0_pInt,0_pInt) - plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) plasticState(p)%offsetDeltaState = sizeDotState - - startIndex = 1_pInt - endIndex = prm%totalNslip - stt%crss => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) - dot%crss => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) - stt%crss = spread(prm%crss0, 2, NipcMyPhase) - plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - - startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip - stt%crss_back => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) - dot%crss_back => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - - startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip - stt%accshear => plasticState(p)%state (startIndex:endIndex,1:NipcMyPhase) - dot%accshear => plasticState(p)%dotState (startIndex:endIndex,1:NipcMyPhase) - plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear - -!---------------------------------------------------------------------------------------------- -!locally define deltaState alias - o = endIndex - - startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip - stt%sense => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip - stt%chi0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip - stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,1:NipcMyPhase) - delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) - - plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally - - - offset_slip = plasticState(p)%nSlip - plasticState(p)%slipRate => & - plasticState(p)%dotState(offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) - plasticState(p)%accumulatedSlip => & - plasticState(p)%state(offset_slip+1:offset_slip+plasticState(p)%nSlip,1:NipcMyPhase) - - end associate - end do - end subroutine plastic_kinehardening_init - !-------------------------------------------------------------------------------------------------- -! sanity checks - - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%crss0 (1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%tau1 (1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' - ! if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - ! if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' +! locally defined state aliases and initialization of state0 and aTolState + startIndex = 1_pInt + endIndex = prm%totalNslip + stt%crss => plasticState(p)%state (startIndex:endIndex,:) + dot%crss => plasticState(p)%dotState(startIndex:endIndex,:) + stt%crss = spread(prm%crss0, 2, NipcMyPhase) + plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance + startIndex = endIndex + 1_pInt + 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 + endIndex = endIndex + prm%totalNslip + stt%accshear => plasticState(p)%state (startIndex:endIndex,:) + dot%accshear => plasticState(p)%dotState(startIndex:endIndex,:) + plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear + ! global alias + plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) + plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) + + o = plasticState(p)%offsetDeltaState + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip + stt%sense => plasticState(p)%state (startIndex :endIndex ,:) + delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip + stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) + delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip + stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) + delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + + end associate + enddo + +end subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - + implicit none - real(pReal), dimension(3,3), intent(out) :: & + real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress @@ -404,24 +374,24 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) of integer(pInt) :: & - j,k,l,m,n + i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg, & dgdot_dtau_pos,dgdot_dtau_neg - associate(prm => param(instance), stt => state(instance)) - - Lp = 0.0_pReal + Lp = 0.0_pReal dLp_dMp = 0.0_pReal + associate(prm => param(instance), stt => state(instance)) + call kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) - do j = 1_pInt, prm%totalNslip - Lp = Lp + (gdot_pos(j)+gdot_neg(j))*prm%Schmid_slip(1:3,1:3,j) + do i = 1_pInt, prm%totalNslip + Lp = Lp + (gdot_pos(i)+gdot_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) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & - + dgdot_dtau_pos(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_pos(m,n,j) & - + dgdot_dtau_neg(j)*prm%Schmid_slip(k,l,j)*prm%nonSchmid_neg(m,n,j) + + dgdot_dtau_pos(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_pos(m,n,i) & + + dgdot_dtau_neg(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_neg(m,n,i) enddo end associate @@ -447,7 +417,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(pInt), intent(in) :: & instance, & of @@ -455,7 +425,7 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) gdot_pos,gdot_neg, & sense - associate( prm => param(instance), stt => state(instance), del => deltaState(instance)) + associate(prm => param(instance), stt => state(instance), del => deltaState(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... @@ -496,12 +466,13 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer(pInt), intent(in) :: & instance, & of + integer(pInt) :: & - j + i real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg real(pReal) :: & @@ -514,11 +485,11 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) - do j = 1_pInt, prm%totalNslip - dot%crss(j,of) = dot_product(prm%interaction_SlipSlip(j,:),dot%accshear(:,of)) & - * ( prm%theta1(j) & - + (prm%theta0(j) - prm%theta1(j) + prm%theta0(j)*prm%theta1(j)*sumGamma/prm%tau1(j)) & - *exp(-sumGamma*prm%theta0(j)/prm%tau1(j)) & + 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_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & @@ -550,19 +521,18 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,instance))) :: & postResults integer(pInt) :: & - o,c,j - + o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg c = 0_pInt - associate( prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) - outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) + outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) case (crss_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%crss(:,of) @@ -593,13 +563,14 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) c = c + prm%totalNslip case (resolvedstress_ID) - do j = 1_pInt, prm%totalNslip - postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) + do i = 1_pInt, prm%totalNslip + postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) enddo c = c + prm%totalNslip - + end select enddo outputsLoop + end associate end function plastic_kinehardening_postResults @@ -607,25 +578,27 @@ end function plastic_kinehardening_postResults !-------------------------------------------------------------------------------------------------- !> @brief calculates shear rates on slip systems and derivatives with respect to resolved stress -!> @details: Shear rates are calculated only optionally. NOTE: Against the common convention, the -!> result (i.e. intent(out)) variables are the last to have the optional arguments at the end +!> @details: Shear rates are calculated only optionally. +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) +pure subroutine kinetics(Mp,instance,of, & + gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) use prec, only: & dNeq0 use math, only: & math_mul33xx33 implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp - integer(pInt), intent(in) :: & - instance, & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & of real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & gdot_pos, & gdot_neg - real(pReal), dimension(param(instance)%totalNslip), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNslip), intent(out), optional :: & dgdot_dtau_pos, & dgdot_dtau_neg @@ -636,7 +609,7 @@ pure subroutine kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_d integer(pInt) :: i logical :: nonSchmidActive - associate( prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance)) nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 1e42876f9..16aac1ead 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -77,6 +77,7 @@ module plastic_phenopowerlaw type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + type, private :: tPhenopowerlawState real(pReal), pointer, dimension(:,:) :: & xi_slip, & @@ -392,9 +393,9 @@ end subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !> @details asumme that deformation by dislocation glide affects twinned and untwinned volume -! equally (Taylor assumption). Twinning happens only in untwinned volume ( +! equally (Taylor assumption). Twinning happens only in untwinned volume !-------------------------------------------------------------------------------------------------- -subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) +pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(out) :: & @@ -411,11 +412,11 @@ subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) integer(pInt) :: & i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & - dgdot_dtauslip_pos,dgdot_dtauslip_neg, & - gdot_slip_pos,gdot_slip_neg + gdot_slip_pos,gdot_slip_neg, & + dgdot_dtauslip_pos,dgdot_dtauslip_neg real(pReal), dimension(param(instance)%totalNtwin) :: & gdot_twin,dgdot_dtautwin - + Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -626,7 +627,7 @@ pure subroutine kinetics_slip(Mp,instance,of, & end where where(dNeq0(tau_slip_neg)) - gdot_slip_neg = 0.5_pReal*prm%gdot0_slip & + gdot_slip_neg = prm%gdot0_slip * 0.5_pReal & ! only used if non-Schmid active, always 1/2 * sign(abs(tau_slip_neg/stt%xi_slip(:,of))**prm%n_slip, tau_slip_neg) else where gdot_slip_neg = 0.0_pReal From aa5d3bf9a3214d47e538850959e92076d5dbd313 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 07:07:55 +0100 Subject: [PATCH 187/372] simplifications --- src/plastic_kinematichardening.f90 | 103 ++++++++++++----------------- 1 file changed, 43 insertions(+), 60 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 20a09c7e9..f514ac78d 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -178,7 +178,7 @@ subroutine plastic_kinehardening_init if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & - delta => deltaState(phase_plasticityInstance(p)), & + dlt => deltaState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)),& config => config_phase(p)) @@ -196,8 +196,8 @@ subroutine plastic_kinehardening_init prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) ! sanity checks - if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//'aTolresistance ' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//'aTolShear ' + if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//' aTolresistance' + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' !-------------------------------------------------------------------------------------------------- ! slip related parameters @@ -208,7 +208,7 @@ subroutine plastic_kinehardening_init config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& - defaultVal = emptyRealArray) + defaultVal = emptyRealArray) prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1_pInt) prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) else @@ -219,25 +219,27 @@ subroutine plastic_kinehardening_init config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%crss0 = config%getFloats('crss0', requiredShape=shape(prm%Nslip)) - prm%tau1 = config%getFloats('tau1', requiredShape=shape(prm%Nslip)) - prm%tau1_b = config%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) - prm%theta0 = config%getFloats('theta0', requiredShape=shape(prm%Nslip)) - prm%theta1 = config%getFloats('theta1', requiredShape=shape(prm%Nslip)) - prm%theta0_b = config%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) - prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + prm%crss0 = config%getFloats('crss0', requiredShape=shape(prm%Nslip)) + prm%tau1 = config%getFloats('tau1', requiredShape=shape(prm%Nslip)) + prm%tau1_b = config%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) + prm%theta0 = config%getFloats('theta0', requiredShape=shape(prm%Nslip)) + prm%theta1 = config%getFloats('theta1', requiredShape=shape(prm%Nslip)) + prm%theta0_b = config%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) + prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + + prm%gdot0 = config%getFloat('gdot0') + prm%n_slip = config%getFloat('n_slip') ! expand: family => system - prm%crss0 = math_expand(prm%crss0, prm%Nslip) - prm%tau1 = math_expand(prm%tau1,prm%Nslip) - prm%tau1_b = math_expand(prm%tau1_b, prm%Nslip) - prm%theta0 = math_expand(prm%theta0,prm%Nslip) - prm%theta1 = math_expand(prm%theta1,prm%Nslip) + prm%crss0 = math_expand(prm%crss0, prm%Nslip) + prm%tau1 = math_expand(prm%tau1, prm%Nslip) + prm%tau1_b = math_expand(prm%tau1_b, prm%Nslip) + prm%theta0 = math_expand(prm%theta0, prm%Nslip) + prm%theta1 = math_expand(prm%theta1, prm%Nslip) prm%theta0_b = math_expand(prm%theta0_b,prm%Nslip) prm%theta1_b = math_expand(prm%theta1_b,prm%Nslip) - prm%gdot0 = config%getFloat('gdot0') - prm%n_slip = config%getFloat('n_slip') + !-------------------------------------------------------------------------------------------------- ! sanity checks @@ -260,31 +262,25 @@ subroutine plastic_kinehardening_init allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID + outputSize = prm%totalNslip select case(outputs(i)) + case ('resistance') outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('accumulatedshear') outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('shearrate') outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('resolvedstress') outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('backstress') outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('sense') outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('chi0') outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip case ('gamma0') outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0_pInt) - outputSize = prm%totalNslip end select @@ -335,18 +331,18 @@ subroutine plastic_kinehardening_init o = plasticState(p)%offsetDeltaState startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%sense => plasticState(p)%state (startIndex :endIndex ,:) - delta%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%sense => plasticState(p)%state (startIndex :endIndex ,:) + dlt%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) - delta%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) + dlt%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) - delta%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) + dlt%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally @@ -425,7 +421,7 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) gdot_pos,gdot_neg, & sense - associate(prm => param(instance), stt => state(instance), del => deltaState(instance)) + associate(prm => param(instance), stt => state(instance), dlt => deltaState(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... @@ -444,13 +440,13 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) !-------------------------------------------------------------------------------------------------- ! switch in sense of shear? where(dNeq(sense,stt%sense(:,of),0.1_pReal)) - del%sense (:,of) = sense - stt%sense(:,of) ! switch sense - del%chi0 (:,of) = abs(stt%crss_back(:,of)) - stt%chi0(:,of) ! remember current backstress magnitude - del%gamma0(:,of) = stt%accshear(:,of) - stt%gamma0(:,of) ! remember current accumulated shear + dlt%sense (:,of) = sense - stt%sense(:,of) ! switch sense + dlt%chi0 (:,of) = abs(stt%crss_back(:,of)) - stt%chi0(:,of) ! remember current backstress magnitude + dlt%gamma0(:,of) = stt%accshear(:,of) - stt%gamma0(:,of) ! remember current accumulated shear else where - del%sense (:,of) = 0.0_pReal - del%chi0 (:,of) = 0.0_pReal - del%gamma0(:,of) = 0.0_pReal + dlt%sense (:,of) = 0.0_pReal + dlt%chi0 (:,of) = 0.0_pReal + dlt%gamma0(:,of) = 0.0_pReal end where end associate @@ -470,7 +466,6 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) instance, & of - integer(pInt) :: & i real(pReal), dimension(param(instance)%totalNslip) :: & @@ -478,8 +473,7 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) real(pReal) :: & sumGamma - - associate( prm => param(instance), stt => state(instance), dot => dotState(instance)) + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) @@ -489,7 +483,7 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) 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)) & + * exp(-sumGamma*prm%theta0(i)/prm%tau1(i)) & ) enddo dot%crss_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & @@ -534,41 +528,30 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) + case (crss_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%crss(:,of) - c = c + prm%totalNslip - case(crss_back_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%crss_back(:,of) - c = c + prm%totalNslip - case (sense_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) - c = c + prm%totalNslip - + postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) case (chi0_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%chi0(:,of) - c = c + prm%totalNslip - case (gamma0_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%gamma0(:,of) - c = c + prm%totalNslip - case (accshear_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear(:,of) - c = c + prm%totalNslip - case (shearrate_ID) postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg - c = c + prm%totalNslip - case (resolvedstress_ID) do i = 1_pInt, prm%totalNslip postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) enddo - c = c + prm%totalNslip - + end select + + c = c + prm%totalNslip + enddo outputsLoop end associate From 705d55a3a5bca7c18ef2352daa688ab9ea46bf93 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 07:20:13 +0100 Subject: [PATCH 188/372] re-enabled sanity checks + slight adjustments to layout --- src/plastic_kinematichardening.f90 | 70 +++++++++++++++--------------- src/plastic_phenopowerlaw.f90 | 9 ++-- 2 files changed, 41 insertions(+), 38 deletions(-) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index f514ac78d..559f305ff 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -7,7 +7,7 @@ !-------------------------------------------------------------------------------------------------- module plastic_kinehardening use prec, only: & - pReal,& + pReal, & pInt implicit none @@ -243,19 +243,21 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! sanity checks - - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%crss0 (1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%tau1 (1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' - ! if (any(plastic_kinehardening_Nslip (1:nSlipFamilies,instance) > 0_pInt & - ! .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' - ! if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - ! if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if (any(prm%crss0 <= 0.0_pReal)) extmsg = trim(extmsg)//' crss0' + if (any(prm%tau1 <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' + if (any(prm%tau1_b <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' + + !ToDo: Any sensible checks for theta? endif slipActive - +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//PLASTICITY_KINEHARDENING_label//')') + !-------------------------------------------------------------------------------------------------- ! output pararameters outputs = config%getStrings('(output)',defaultVal=emptyStringArray) @@ -308,21 +310,21 @@ subroutine plastic_kinehardening_init ! locally defined state aliases and initialization of state0 and aTolState startIndex = 1_pInt endIndex = prm%totalNslip - stt%crss => plasticState(p)%state (startIndex:endIndex,:) - dot%crss => plasticState(p)%dotState(startIndex:endIndex,:) + 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 endIndex = endIndex + prm%totalNslip - stt%crss_back => plasticState(p)%state (startIndex:endIndex,:) - dot%crss_back => plasticState(p)%dotState(startIndex:endIndex,:) + 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 endIndex = endIndex + prm%totalNslip - stt%accshear => plasticState(p)%state (startIndex:endIndex,:) - dot%accshear => plasticState(p)%dotState(startIndex:endIndex,:) + stt%accshear => plasticState(p)%state (startIndex:endIndex,:) + dot%accshear => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolShear ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) @@ -331,18 +333,18 @@ subroutine plastic_kinehardening_init o = plasticState(p)%offsetDeltaState startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%sense => plasticState(p)%state (startIndex :endIndex ,:) - dlt%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%sense => plasticState(p)%state (startIndex :endIndex ,:) + dlt%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) - dlt%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) + dlt%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) - dlt%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) + stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) + dlt%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally @@ -508,33 +510,33 @@ 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(pInt), intent(in) :: & instance, & of real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,instance))) :: & postResults + integer(pInt) :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg - c = 0_pInt associate(prm => param(instance), stt => state(instance)) - + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) - + outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) - + case (crss_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%crss(:,of) case(crss_back_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%crss_back(:,of) case (sense_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) + postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) case (chi0_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%chi0(:,of) case (gamma0_ID) @@ -547,7 +549,7 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) do i = 1_pInt, prm%totalNslip postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) enddo - + end select c = c + prm%totalNslip @@ -568,7 +570,7 @@ end function plastic_kinehardening_postResults pure subroutine kinetics(Mp,instance,of, & gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) use prec, only: & - dNeq0 + dNeq0 use math, only: & math_mul33xx33 @@ -578,14 +580,14 @@ pure subroutine kinetics(Mp,instance,of, & integer(pInt), intent(in) :: & instance, & of - real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & + + real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & gdot_pos, & gdot_neg - real(pReal), dimension(param(instance)%totalNslip), intent(out), optional :: & + real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & dgdot_dtau_pos, & dgdot_dtau_neg - real(pReal), dimension(param(instance)%totalNslip) :: & tau_pos, & tau_neg diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index e2b56cce6..51ffd6eff 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -191,7 +191,7 @@ subroutine plastic_phenopowerlaw_init prm%aTolResistance = config%getFloat('atol_resistance',defaultVal=1.0_pReal) prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) prm%aTolTwinfrac = config%getFloat('atol_twinfrac', defaultVal=1.0e-6_pReal) - + ! sanity checks if (prm%aTolResistance <= 0.0_pReal) extmsg = trim(extmsg)//' aTolresistance' if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' @@ -392,7 +392,7 @@ end subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent -!> @details asumme that deformation by dislocation glide affects twinned and untwinned volume +!> @details asummes that deformation by dislocation glide affects twinned and untwinned volume ! equally (Taylor assumption). Twinning happens only in untwinned volume !-------------------------------------------------------------------------------------------------- pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) @@ -523,7 +523,7 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) of real(pReal), dimension(sum(plastic_phenopowerlaw_sizePostResult(:,instance))) :: & - postResults + postResults integer(pInt) :: & o,c,i @@ -595,13 +595,14 @@ pure subroutine kinetics_slip(Mp,instance,of, & integer(pInt), intent(in) :: & instance, & of - + real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & gdot_slip_pos, & gdot_slip_neg real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & dgdot_dtau_slip_pos, & dgdot_dtau_slip_neg + real(pReal), dimension(param(instance)%totalNslip) :: & tau_slip_pos, & tau_slip_neg From 4037085f6c29854a7c277c0e7583c1cb41fa6d32 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 07:24:02 +0100 Subject: [PATCH 189/372] whitespace not needed --- src/plastic_disloUCLA.f90 | 30 ++++++++--------- src/plastic_isotropic.f90 | 54 +++++++++++++++--------------- src/plastic_kinematichardening.f90 | 36 ++++++++++---------- src/plastic_phenopowerlaw.f90 | 28 ++++++++-------- 4 files changed, 74 insertions(+), 74 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 67adb083b..15c050934 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -227,7 +227,7 @@ subroutine plastic_disloUCLA_init() prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) + prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) prm%rhoDip0 = config%getFloats('rhoedgedip0', requiredShape=shape(prm%Nslip)) prm%v0 = config%getFloats('v0', requiredShape=shape(prm%Nslip)) prm%burgers = config%getFloats('slipburgers', requiredShape=shape(prm%Nslip)) @@ -268,7 +268,7 @@ subroutine plastic_disloUCLA_init() prm%clambda = math_expand(prm%clambda, prm%Nslip) prm%atomicVolume = math_expand(prm%atomicVolume, prm%Nslip) prm%minDipDistance = math_expand(prm%minDipDistance, prm%Nslip) - + prm%tau0 = prm%tau_peierls + prm%SolidSolutionStrength ! sanity checks @@ -280,7 +280,7 @@ subroutine plastic_disloUCLA_init() if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' d0' if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' qsd' - + !if (plastic_disloUCLA_CAtomicVolume(instance) <= 0.0_pReal) & ! call IO_error(211_pInt,el=instance,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOUCLA_label//')') else slipActive @@ -338,7 +338,7 @@ subroutine plastic_disloUCLA_init() plasticState(p)%sizePostResults = sum(plastic_disloUCLA_sizePostResult(:,phase_plasticityInstance(p))) allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) - + i = 0_pInt mySlipFamilies: do f = 1_pInt,size(prm%Nslip,1) index_myFamily = sum(prm%Nslip(1:f-1_pInt)) @@ -416,7 +416,7 @@ subroutine plastic_disloUCLA_dependentState(instance,of) dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dst%dislocationSpacing(:,of)/prm%Clambda) dst%dislocationSpacing(:,of) = dst%mfp(:,of) ! ToDo: Hack to recover wrong behavior for the moment - + end associate @@ -450,7 +450,7 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst Lp = 0.0_pReal dLp_dMp = 0.0_pReal - + associate(prm => param(instance)) call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) @@ -461,7 +461,7 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst + 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 - + end associate end subroutine plastic_disloUCLA_LpAndItsTangent @@ -600,12 +600,12 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe end function plastic_disloUCLA_postResults -!-------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @brief Shear rates on slip systems, their derivatives with respect to resolved stress and the ! resolved stresss -!> @details Derivatives and resolved stress are calculated only optionally. -! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to -! have the optional arguments at the end +!> @details Derivatives and resolved stress are calculated only optionally. +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- pure subroutine kinetics(Mp,Temperature,instance,of, & gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos1,tau_slip_neg1) @@ -642,13 +642,13 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & integer(pInt) :: j associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) - + do j = 1_pInt, prm%totalNslip tau_slip_pos(j) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,j)) tau_slip_neg(j) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,j)) enddo - - + + if (present(tau_slip_pos1)) tau_slip_pos1 = tau_slip_pos if (present(tau_slip_neg1)) tau_slip_neg1 = tau_slip_neg @@ -735,7 +735,7 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & ) & /(2.0_pReal*prm%burgers**2.0_pReal*tau_slip_neg & + prm%omega * prm%B* effectiveLength**2.0_pReal* needsGoodName )**2.0_pReal - + dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal else where significantNegativeTau2 dgdot_dtauslip_neg = 0.0_pReal diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index c7d92651a..4f96a5648 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -44,7 +44,7 @@ module plastic_isotropic aTolShear integer(pInt) :: & of_debug = 0_pInt - integer(kind(undefined_ID)), allocatable, dimension(:) :: & + integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID logical :: & dilatation @@ -119,7 +119,7 @@ subroutine plastic_isotropic_init() p, i, & NipcMyPhase, & sizeState, sizeDotState - + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & @@ -154,7 +154,7 @@ subroutine plastic_isotropic_init() 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) @@ -175,22 +175,22 @@ subroutine plastic_isotropic_init() 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%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%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 ' - + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//'atol_shear ' + !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range if (extmsg /= '') & @@ -242,7 +242,7 @@ subroutine plastic_isotropic_init() ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(2:2,1:NipcMyPhase) plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,1:NipcMyPhase) - + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate @@ -289,15 +289,15 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) 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) + 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 + 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 @@ -318,7 +318,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) Lp = 0.0_pReal dLp_dMp = 0.0_pReal end if - + end associate end subroutine plastic_isotropic_LpAndItsTangent @@ -338,7 +338,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) 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(pInt), intent(in) :: & @@ -355,10 +355,10 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) 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) + 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 @@ -404,15 +404,15 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) 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 @@ -431,7 +431,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) dot%flowstress (of) = hardening * gamma_dot dot%accumulatedShear(of) = gamma_dot - + end associate end subroutine plastic_isotropic_dotState @@ -461,13 +461,13 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) 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_pInt outputsLoop: do o = 1_pInt,size(prm%outputID) @@ -483,7 +483,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) end select enddo outputsLoop - + end associate end function plastic_isotropic_postResults diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 559f305ff..f8add7937 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -40,7 +40,7 @@ module plastic_kinehardening crss0, & !< initial critical shear stress for slip (input parameter, per family) theta0, & !< initial hardening rate of forward stress for each slip theta1, & !< asymptotic hardening rate of forward stress for each slip > - theta0_b, & !< initial hardening rate of back stress for each slip > + theta0_b, & !< initial hardening rate of back stress for each slip > theta1_b, & !< asymptotic hardening rate of back stress for each slip > tau1, & tau1_b, & @@ -226,7 +226,7 @@ subroutine plastic_kinehardening_init prm%theta1 = config%getFloats('theta1', requiredShape=shape(prm%Nslip)) prm%theta0_b = config%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) - + prm%gdot0 = config%getFloat('gdot0') prm%n_slip = config%getFloat('n_slip') @@ -266,7 +266,7 @@ subroutine plastic_kinehardening_init outputID = undefined_ID outputSize = prm%totalNslip select case(outputs(i)) - + case ('resistance') outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) case ('accumulatedshear') @@ -316,7 +316,7 @@ subroutine plastic_kinehardening_init plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance startIndex = endIndex + 1_pInt - endIndex = endIndex + prm%totalNslip + 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 @@ -335,7 +335,7 @@ subroutine plastic_kinehardening_init endIndex = endIndex + prm%totalNslip stt%sense => plasticState(p)%state (startIndex :endIndex ,:) dlt%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) - + startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) @@ -345,7 +345,7 @@ subroutine plastic_kinehardening_init endIndex = endIndex + prm%totalNslip stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) dlt%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) - + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate @@ -391,7 +391,7 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) + dgdot_dtau_pos(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_pos(m,n,i) & + dgdot_dtau_neg(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_neg(m,n,i) enddo - + end associate end subroutine plastic_kinehardening_LpAndItsTangent @@ -424,10 +424,10 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) sense associate(prm => param(instance), stt => state(instance), dlt => deltaState(instance)) - + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) sense = merge(state(instance)%sense(:,of), & ! keep existing... - sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined + sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction #ifdef DEBUG @@ -450,7 +450,7 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) dlt%chi0 (:,of) = 0.0_pReal dlt%gamma0(:,of) = 0.0_pReal end where - + end associate end subroutine plastic_kinehardening_deltaState @@ -474,13 +474,13 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) gdot_pos,gdot_neg real(pReal) :: & sumGamma - + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) - sumGamma = sum(stt%accshear(:,of)) - + 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) & @@ -493,8 +493,8 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) (prm%theta0_b - prm%theta1_b & + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& ) *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & - ) - + ) + end associate end subroutine plastic_kinehardening_dotState @@ -551,9 +551,9 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) enddo end select - + c = c + prm%totalNslip - + enddo outputsLoop end associate @@ -595,7 +595,7 @@ pure subroutine kinetics(Mp,instance,of, & logical :: nonSchmidActive associate(prm => param(instance), stt => state(instance)) - + nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt do i = 1_pInt, prm%totalNslip diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 51ffd6eff..abcb10bdb 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -221,7 +221,7 @@ subroutine plastic_phenopowerlaw_init 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))]) - + prm%gdot0_slip = config%getFloat('gdot0_slip') prm%n_slip = config%getFloat('n_slip') prm%a_slip = config%getFloat('a_slip') @@ -392,7 +392,7 @@ end subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent -!> @details asummes that deformation by dislocation glide affects twinned and untwinned volume +!> @details asummes that deformation by dislocation glide affects twinned and untwinned volume ! equally (Taylor assumption). Twinning happens only in untwinned volume !-------------------------------------------------------------------------------------------------- pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) @@ -419,9 +419,9 @@ pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - + 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 Lp = Lp + (gdot_slip_pos(i)+gdot_slip_neg(i))*prm%Schmid_slip(1:3,1:3,i) @@ -438,7 +438,7 @@ pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) 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 - + end associate end subroutine plastic_phenopowerlaw_LpAndItsTangent @@ -578,8 +578,8 @@ end function plastic_phenopowerlaw_postResults !-------------------------------------------------------------------------------------------------- !> @brief Shear rates on slip systems and their derivatives with respect to resolved stress -!> @details Derivatives are calculated only optionally. -! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +!> @details Derivatives are calculated only optionally. +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to ! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- pure subroutine kinetics_slip(Mp,instance,of, & @@ -610,7 +610,7 @@ pure subroutine kinetics_slip(Mp,instance,of, & logical :: nonSchmidActive associate(prm => param(instance), stt => state(instance)) - + nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt do i = 1_pInt, prm%totalNslip @@ -656,7 +656,7 @@ end subroutine kinetics_slip !> @brief Shear rates on twin systems and their derivatives with respect to resolved stress. ! twinning is assumed to take place only in untwinned volume. !> @details Derivates are calculated only optionally. -! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to ! have the optional arguments at the end. !-------------------------------------------------------------------------------------------------- pure subroutine kinetics_twin(Mp,instance,of,& @@ -672,7 +672,7 @@ pure subroutine kinetics_twin(Mp,instance,of,& integer(pInt), intent(in) :: & instance, & of - + real(pReal), dimension(param(instance)%totalNtwin), intent(out) :: & gdot_twin real(pReal), dimension(param(instance)%totalNtwin), intent(out), optional :: & @@ -681,17 +681,17 @@ pure subroutine kinetics_twin(Mp,instance,of,& real(pReal), dimension(param(instance)%totalNtwin) :: & tau_twin integer(pInt) :: i - + associate(prm => param(instance), stt => state(instance)) do i = 1_pInt, prm%totalNtwin tau_twin(i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) enddo - + where(tau_twin > 0.0_pReal) gdot_twin = (1.0_pReal-sum(stt%gamma_twin(:,of)/prm%gamma_twin_char)) & ! only twin in untwinned volume fraction * prm%gdot0_twin*(abs(tau_twin)/stt%xi_twin(:,of))**prm%n_twin - else where + else where gdot_twin = 0.0_pReal end where @@ -702,7 +702,7 @@ pure subroutine kinetics_twin(Mp,instance,of,& dgdot_dtau_twin = 0.0_pReal end where endif - + end associate end subroutine kinetics_twin From e06fc036c5a20da2375baff49dd79f72417596ed Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 07:36:11 +0100 Subject: [PATCH 190/372] have dotState after Lp/Li --- src/plastic_disloUCLA.f90 | 60 ++++++++++---------- src/plastic_kinematichardening.f90 | 88 +++++++++++++++--------------- src/plastic_none.f90 | 1 - 3 files changed, 74 insertions(+), 75 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 15c050934..734d077e3 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -393,36 +393,6 @@ subroutine plastic_disloUCLA_init() end subroutine plastic_disloUCLA_init -!-------------------------------------------------------------------------------------------------- -!> @brief calculates derived quantities from state -!-------------------------------------------------------------------------------------------------- -subroutine plastic_disloUCLA_dependentState(instance,of) - - implicit none - integer(pInt), intent(in) :: instance, of - - integer(pInt) :: & - i - - associate(prm => param(instance), stt => state(instance),dst => dependentState(instance)) - - forall (i = 1_pInt:prm%totalNslip) - dst%dislocationSpacing(i,of) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & - prm%forestProjectionEdge(:,i))) - dst%threshold_stress(i,of) = prm%mu*prm%burgers(i) & - * sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & - prm%interaction_SlipSlip(i,:))) - end forall - - dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dst%dislocationSpacing(:,of)/prm%Clambda) - dst%dislocationSpacing(:,of) = dst%mfp(:,of) ! ToDo: Hack to recover wrong behavior for the moment - - end associate - - -end subroutine plastic_disloUCLA_dependentState - - !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- @@ -531,6 +501,36 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) end subroutine plastic_disloUCLA_dotState +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_dependentState(instance,of) + + implicit none + integer(pInt), intent(in) :: instance, of + + integer(pInt) :: & + i + + associate(prm => param(instance), stt => state(instance),dst => dependentState(instance)) + + forall (i = 1_pInt:prm%totalNslip) + dst%dislocationSpacing(i,of) = sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & + prm%forestProjectionEdge(:,i))) + dst%threshold_stress(i,of) = prm%mu*prm%burgers(i) & + * sqrt(dot_product(stt%rhoEdge(:,of)+stt%rhoEdgeDip(:,of), & + prm%interaction_SlipSlip(i,:))) + end forall + + dst%mfp(:,of) = prm%grainSize/(1.0_pReal+prm%grainSize*dst%dislocationSpacing(:,of)/prm%Clambda) + dst%dislocationSpacing(:,of) = dst%mfp(:,of) ! ToDo: Hack to recover wrong behavior for the moment + + end associate + + +end subroutine plastic_disloUCLA_dependentState + + !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index f8add7937..20d748a88 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -397,6 +397,50 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) end subroutine plastic_kinehardening_LpAndItsTangent +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_dotState(Mp,instance,of) + + implicit none + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer(pInt), intent(in) :: & + instance, & + of + + integer(pInt) :: & + i + real(pReal), dimension(param(instance)%totalNslip) :: & + gdot_pos,gdot_neg + real(pReal) :: & + sumGamma + + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) + + call kinetics(Mp,instance,of,gdot_pos,gdot_neg) + 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_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & + ( prm%theta1_b + & + (prm%theta0_b - prm%theta1_b & + + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& + ) *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & + ) + + end associate + +end subroutine plastic_kinehardening_dotState + + !-------------------------------------------------------------------------------------------------- !> @brief calculates (instantaneous) incremental change of microstructure !-------------------------------------------------------------------------------------------------- @@ -456,50 +500,6 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) end subroutine plastic_kinehardening_deltaState -!-------------------------------------------------------------------------------------------------- -!> @brief calculates the rate of change of microstructure -!-------------------------------------------------------------------------------------------------- -subroutine plastic_kinehardening_dotState(Mp,instance,of) - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer(pInt), intent(in) :: & - instance, & - of - - integer(pInt) :: & - i - real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_pos,gdot_neg - real(pReal) :: & - sumGamma - - associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) - - call kinetics(Mp,instance,of,gdot_pos,gdot_neg) - 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_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & - ( prm%theta1_b + & - (prm%theta0_b - prm%theta1_b & - + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))& - ) *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) & - ) - - end associate - -end subroutine plastic_kinehardening_dotState - - !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index 2c6ca6e93..0b3df43ef 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -60,7 +60,6 @@ subroutine plastic_none_init !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - call material_allocatePlasticState(p,NipcMyPhase,0_pInt,0_pInt,0_pInt, & 0_pInt,0_pInt,0_pInt) plasticState(p)%sizePostResults = 0_pInt From 995122504ebac50a9ec8f596bf2c5c14c6f78664 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 08:04:02 +0100 Subject: [PATCH 191/372] cross comparing --- src/plastic_disloUCLA.f90 | 58 +++++++++++----------- src/plastic_isotropic.f90 | 70 +++++++++++++-------------- src/plastic_kinematichardening.f90 | 77 +++++++++++++++--------------- src/plastic_phenopowerlaw.f90 | 17 ++++--- 4 files changed, 111 insertions(+), 111 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 734d077e3..c9a885e68 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -77,8 +77,6 @@ module plastic_disloUCLA dipoleformation end type !< container type for internal constitutive parameters - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - type, private :: tDisloUCLAState real(pReal), pointer, dimension(:,:) :: & rhoEdge, & @@ -93,6 +91,8 @@ module plastic_disloUCLA threshold_stress end type tDisloUCLAdependentState + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) type(tDisloUCLAState ), allocatable, dimension(:), private :: & dotState, & state @@ -110,6 +110,7 @@ module plastic_disloUCLA contains + !-------------------------------------------------------------------------------------------------- !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks @@ -152,7 +153,7 @@ subroutine plastic_disloUCLA_init() f,j,k,o, & Ninstance, & p, i, & - NipcMyPhase, outputSize, & + NipcMyPhase, & sizeState, sizeDotState, & startIndex, endIndex @@ -217,7 +218,7 @@ subroutine plastic_disloUCLA_init() config%getFloat('c/a',defaultVal=0.0_pReal)) if(structure=='bcc') then prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& - defaultVal = emptyRealArray) + defaultVal = emptyRealArray) prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1_pInt) prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) else @@ -272,17 +273,17 @@ subroutine plastic_disloUCLA_init() prm%tau0 = prm%tau_peierls + prm%SolidSolutionStrength ! sanity checks - if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0' - if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0' - if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//' v0' - if (any(prm%burgers <= 0.0_pReal)) extmsg = trim(extmsg)//' slipburgers' - if (any(prm%H0kp <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge' - if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' - if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' d0' - if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' qsd' + if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' d0' + if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' qsd' + if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0' + if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0' + if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//' v0' + if (any(prm%burgers <= 0.0_pReal)) extmsg = trim(extmsg)//' slipburgers' + if (any(prm%H0kp <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge' + if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' + if (any(prm%minDipDistance <= 0.0_pReal)) extmsg = trim(extmsg)//' cedgedipmindistance or slipburgers' + if (any(prm%atomicVolume <= 0.0_pReal)) extmsg = trim(extmsg)//' catomicvolume or slipburgers' - !if (plastic_disloUCLA_CAtomicVolume(instance) <= 0.0_pReal) & - ! call IO_error(211_pInt,el=instance,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOUCLA_label//')') else slipActive allocate(prm%rho0(0)) allocate(prm%rhoDip0(0)) @@ -299,7 +300,6 @@ subroutine plastic_disloUCLA_init() allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID - outputSize = prm%totalNslip select case(trim(outputs(i))) case ('edge_density') @@ -321,7 +321,7 @@ subroutine plastic_disloUCLA_init() if (outputID /= undefined_ID) then plastic_disloUCLA_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_disloUCLA_sizePostResult(i,phase_plasticityInstance(p)) = outputSize + plastic_disloUCLA_sizePostResult(i,phase_plasticityInstance(p)) = prm%totalNslip prm%outputID = [prm%outputID, outputID] endif @@ -329,7 +329,7 @@ subroutine plastic_disloUCLA_init() !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase==p) + NipcMyPhase = count(material_phase == p) sizeDotState = int(size(['rhoEdge ','rhoEdgeDip ','accshearslip']),pInt) * prm%totalNslip sizeState = sizeDotState @@ -375,7 +375,7 @@ subroutine plastic_disloUCLA_init() endIndex = endIndex + prm%totalNslip stt%accshear_slip=>plasticState(p)%state(startIndex:endIndex,:) dot%accshear_slip=>plasticState(p)%dotState(startIndex:endIndex,:) - plasticState(p)%aTolState(startIndex:endIndex) = 1e6_pReal + plasticState(p)%aTolState(startIndex:endIndex) = 1e6_pReal !ToDo: better make optional parameter ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) @@ -415,8 +415,8 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst integer(pInt) :: & i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & - dgdot_dtauslip_pos,dgdot_dtauslip_neg, & - gdot_slip_pos,gdot_slip_neg + gdot_slip_pos,gdot_slip_neg, & + dgdot_dtauslip_pos,dgdot_dtauslip_neg Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -424,13 +424,13 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst associate(prm => param(instance)) call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) - slipSystems: do i = 1_pInt, prm%totalNslip + do i = 1_pInt, 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) & 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 + enddo end associate @@ -449,12 +449,13 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) math_clip implicit none - real(pReal), dimension(3,3), intent(in):: & + real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pReal), intent(in) :: & temperature !< temperature - integer(pInt), intent(in) :: & - instance, of + integer(pInt), intent(in) :: & + instance, & + of real(pReal) :: & VacancyDiffusion @@ -507,7 +508,9 @@ end subroutine plastic_disloUCLA_dotState subroutine plastic_disloUCLA_dependentState(instance,of) implicit none - integer(pInt), intent(in) :: instance, of + integer(pInt), intent(in) :: & + instance, & + of integer(pInt) :: & i @@ -527,7 +530,6 @@ subroutine plastic_disloUCLA_dependentState(instance,of) end associate - end subroutine plastic_disloUCLA_dependentState diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 4f96a5648..219226ad4 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -50,14 +50,14 @@ module plastic_isotropic dilatation end type - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - type, private :: tIsotropicState real(pReal), pointer, dimension(:) :: & flowstress, & accumulatedShear end type + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) type(tIsotropicState), allocatable, dimension(:), private :: & dotState, & state @@ -140,8 +140,8 @@ subroutine plastic_isotropic_init() if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), Ninstance),source=0_pInt) - allocate(plastic_isotropic_output(maxval(phase_Noutput), Ninstance)) + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(plastic_isotropic_output(maxval(phase_Noutput),Ninstance)) plastic_isotropic_output = '' allocate(param(Ninstance)) @@ -161,35 +161,35 @@ subroutine plastic_isotropic_init() endif #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%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 ' + 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 @@ -231,17 +231,17 @@ subroutine plastic_isotropic_init() !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - stt%flowstress => plasticState(p)%state (1,1:NipcMyPhase) + stt%flowstress => plasticState(p)%state (1,:) stt%flowstress = prm%tau0 - dot%flowstress => plasticState(p)%dotState (1,1:NipcMyPhase) - plasticState(p)%aTolState(1) = prm%aTolFlowstress + dot%flowstress => plasticState(p)%dotState(1,:) + plasticState(p)%aTolState(1) = prm%aTolFlowstress - stt%accumulatedShear => plasticState(p)%state (2,1:NipcMyPhase) - dot%accumulatedShear => plasticState(p)%dotState (2,1:NipcMyPhase) - plasticState(p)%aTolState(2) = prm%aTolShear + 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,1:NipcMyPhase) - plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,1:NipcMyPhase) + 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 diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 20d748a88..8576d5425 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -61,8 +61,6 @@ module plastic_kinehardening outputID !< ID of each post result output end type - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - type, private :: tKinehardeningState real(pReal), pointer, dimension(:,:) :: & !< vectors along NipcMyInstance crss, & !< critical resolved stress @@ -73,6 +71,8 @@ module plastic_kinehardening accshear !< accumulated (absolute) shear end type + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & deltaState, & @@ -87,7 +87,6 @@ module plastic_kinehardening private :: & kinetics - contains @@ -140,7 +139,7 @@ subroutine plastic_kinehardening_init integer(pInt) :: & Ninstance, & p, i, o, & - NipcMyPhase, outputSize, & + NipcMyPhase, & sizeState, sizeDeltaState, sizeDotState, & startIndex, endIndex @@ -243,11 +242,11 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! sanity checks - if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if ( prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if ( prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (any(prm%crss0 <= 0.0_pReal)) extmsg = trim(extmsg)//' crss0' - if (any(prm%tau1 <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' - if (any(prm%tau1_b <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' + if (any(prm%tau1 <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' + if (any(prm%tau1_b <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' !ToDo: Any sensible checks for theta? @@ -264,41 +263,40 @@ subroutine plastic_kinehardening_init allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID - outputSize = prm%totalNslip select case(outputs(i)) - case ('resistance') - outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('accumulatedshear') - outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('shearrate') - outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('resolvedstress') - outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('backstress') - outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('sense') - outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('chi0') - outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('gamma0') - outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('resistance') + outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('accumulatedshear') + outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('shearrate') + outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('resolvedstress') + outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('backstress') + outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('sense') + outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('chi0') + outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0_pInt) + case ('gamma0') + outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0_pInt) - end select + end select - if (outputID /= undefined_ID) then - plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = outputSize - prm%outputID = [prm%outputID , outputID] - endif + if (outputID /= undefined_ID) then + plastic_kinehardening_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_kinehardening_sizePostResult(i,phase_plasticityInstance(p)) = prm%totalNslip + prm%outputID = [prm%outputID , outputID] + endif - end do + enddo !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - sizeDotState = size(['crss ','crss_back', 'accshear ']) * prm%TotalNslip - sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0' ]) * prm%TotalNslip + sizeDotState = size(['crss ','crss_back', 'accshear ']) * prm%totalNslip + sizeDeltaState = size(['sense ', 'chi0 ', 'gamma0' ]) * prm%totalNslip sizeState = sizeDotState + sizeDeltaState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & @@ -349,6 +347,7 @@ subroutine plastic_kinehardening_init plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate + enddo end subroutine plastic_kinehardening_init @@ -380,7 +379,7 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) Lp = 0.0_pReal dLp_dMp = 0.0_pReal - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance)) call kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) @@ -411,10 +410,11 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) integer(pInt) :: & i - real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_pos,gdot_neg real(pReal) :: & sumGamma + real(pReal), dimension(param(instance)%totalNslip) :: & + gdot_pos,gdot_neg + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) @@ -526,8 +526,6 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) associate(prm => param(instance), stt => state(instance)) - call kinetics(Mp,instance,of,gdot_pos,gdot_neg) - outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) @@ -544,6 +542,7 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) case (accshear_ID) postResults(c+1_pInt: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 case (resolvedstress_ID) do i = 1_pInt, prm%totalNslip diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index abcb10bdb..b6387d88f 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -74,9 +74,6 @@ module plastic_phenopowerlaw outputID !< ID of each post result output end type !< container type for internal constitutive parameters - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - type, private :: tPhenopowerlawState real(pReal), pointer, dimension(:,:) :: & xi_slip, & @@ -85,6 +82,8 @@ module plastic_phenopowerlaw gamma_twin end type + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) type(tPhenopowerlawState), allocatable, dimension(:), private :: & dotState, & state @@ -233,9 +232,9 @@ subroutine plastic_phenopowerlaw_init prm%H_int = math_expand(prm%H_int, prm%Nslip) ! sanity checks - if (prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0_slip' - if (prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//' a_slip' - if (prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if ( prm%gdot0_slip <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0_slip' + if ( prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//' a_slip' + if ( prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (any(prm%xi_slip_0 <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_slip_0' if (any(prm%xi_slip_sat < prm%xi_slip_0)) extmsg = trim(extmsg)//' xi_slip_sat' else slipActive @@ -342,8 +341,8 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - sizeDotState = size(['tau_slip ','gamma_slip']) * prm%TotalNslip & - + size(['tau_twin ','gamma_twin']) * prm%TotalNtwin + sizeDotState = size(['tau_slip ','gamma_slip']) * prm%totalNslip & + + size(['tau_twin ','gamma_twin']) * prm%totalNtwin sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & @@ -466,7 +465,7 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) left_SlipSlip,right_SlipSlip, & gdot_slip_pos,gdot_slip_neg - associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) sumGamma = sum(stt%gamma_slip(:,of)) sumF = sum(stt%gamma_twin(:,of)/prm%gamma_twin_char) From 996d686a8968adcfae69f5997412666d38926f65 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 7 Jan 2019 08:15:27 +0100 Subject: [PATCH 192/372] slip suffix not needed for slip only models --- src/plastic_disloUCLA.f90 | 151 ++++++++++++++--------------- src/plastic_kinematichardening.f90 | 45 +++++---- 2 files changed, 97 insertions(+), 99 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index c9a885e68..9d8703277 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -63,8 +63,7 @@ module plastic_disloUCLA interaction_SlipSlip, & !< slip resistance from slip activity forestProjectionEdge real(pReal), allocatable, dimension(:,:,:) :: & - Schmid_slip, & - Schmid_twin, & + Schmid, & nonSchmid_pos, & nonSchmid_neg integer(pInt) :: & @@ -81,7 +80,7 @@ module plastic_disloUCLA real(pReal), pointer, dimension(:,:) :: & rhoEdge, & rhoEdgeDip, & - accshear_slip + accshear end type type, private :: tDisloUCLAdependentState @@ -214,16 +213,16 @@ subroutine plastic_disloUCLA_init() prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config%getFloat('c/a',defaultVal=0.0_pReal)) + prm%Schmid = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& + config%getFloat('c/a',defaultVal=0.0_pReal)) if(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) else - prm%nonSchmid_pos = prm%Schmid_slip - prm%nonSchmid_neg = prm%Schmid_slip + prm%nonSchmid_pos = prm%Schmid + prm%nonSchmid_neg = prm%Schmid endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & @@ -373,8 +372,8 @@ subroutine plastic_disloUCLA_init() startIndex = endIndex + 1_pInt endIndex = endIndex + prm%totalNslip - stt%accshear_slip=>plasticState(p)%state(startIndex:endIndex,:) - dot%accshear_slip=>plasticState(p)%dotState(startIndex:endIndex,:) + stt%accshear=>plasticState(p)%state(startIndex:endIndex,:) + dot%accshear=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = 1e6_pReal !ToDo: better make optional parameter ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) @@ -415,21 +414,21 @@ pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,inst integer(pInt) :: & i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg, & - dgdot_dtauslip_pos,dgdot_dtauslip_neg + gdot_pos,gdot_neg, & + dgdot_dtau_pos,dgdot_dtau_neg Lp = 0.0_pReal dLp_dMp = 0.0_pReal associate(prm => param(instance)) - call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) + call kinetics(Mp,Temperature,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) do i = 1_pInt, prm%totalNslip - Lp = Lp + (gdot_slip_pos(i)+gdot_slip_neg(i))*prm%Schmid_slip(1:3,1:3,i) + 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) & 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) + + 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) enddo end associate @@ -460,29 +459,29 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) real(pReal) :: & VacancyDiffusion real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos, gdot_slip_neg,& - tau_slip_pos,& - tau_slip_neg, & + gdot_pos, gdot_neg,& + tau_pos,& + tau_neg, & DotRhoDipFormation, ClimbVelocity, EdgeDipDistance, & DotRhoEdgeDipClimb associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance)) call kinetics(Mp,Temperature,instance,of,& - gdot_slip_pos,gdot_slip_neg, & - tau_slip_pos1 = tau_slip_pos,tau_slip_neg1 = tau_slip_neg) + gdot_pos,gdot_neg, & + tau_pos1 = tau_pos,tau_neg1 = tau_neg) - dot%accshear_slip(:,of) = (gdot_slip_pos+gdot_slip_neg) ! ToDo: needs to be abs + dot%accshear(:,of) = (gdot_pos+gdot_neg) ! ToDo: needs to be abs VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) - where(dEq0(tau_slip_pos)) ! ToDo: use avg of pos and neg + where(dEq0(tau_pos)) ! ToDo: use avg of pos and neg DotRhoDipFormation = 0.0_pReal DotRhoEdgeDipClimb = 0.0_pReal else where - EdgeDipDistance = math_clip((3.0_pReal*prm%mu*prm%burgers)/(16.0_pReal*PI*abs(tau_slip_pos)), & + EdgeDipDistance = math_clip((3.0_pReal*prm%mu*prm%burgers)/(16.0_pReal*PI*abs(tau_pos)), & prm%minDipDistance, & ! lower limit dst%mfp(:,of)) ! upper limit - DotRhoDipFormation = merge(((2.0_pReal*EdgeDipDistance)/prm%burgers)* stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)), & ! ToDo: ignore region of spontaneous annihilation + DotRhoDipFormation = merge(((2.0_pReal*EdgeDipDistance)/prm%burgers)* stt%rhoEdge(:,of)*abs(dot%accshear(:,of)), & ! ToDo: ignore region of spontaneous annihilation 0.0_pReal, & prm%dipoleformation) ClimbVelocity = (3.0_pReal*prm%mu*VacancyDiffusion*prm%atomicVolume/(2.0_pReal*pi*kB*Temperature)) & @@ -490,11 +489,11 @@ subroutine plastic_disloUCLA_dotState(Mp,Temperature,instance,of) DotRhoEdgeDipClimb = (4.0_pReal*ClimbVelocity*stt%rhoEdgeDip(:,of))/(EdgeDipDistance-prm%minDipDistance) ! ToDo: Discuss with Franz: Stress dependency? end where - dot%rhoEdge(:,of) = abs(dot%accshear_slip(:,of))/(prm%burgers*dst%mfp(:,of)) & ! multiplication + dot%rhoEdge(:,of) = abs(dot%accshear(:,of))/(prm%burgers*dst%mfp(:,of)) & ! multiplication - DotRhoDipFormation & - - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdge(:,of)*abs(dot%accshear_slip(:,of)) !* Spontaneous annihilation of 2 single edge dislocations + - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdge(:,of)*abs(dot%accshear(:,of)) !* Spontaneous annihilation of 2 single edge dislocations dot%rhoEdgeDip(:,of) = DotRhoDipFormation & - - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdgeDip(:,of)*abs(dot%accshear_slip(:,of)) & !* Spontaneous annihilation of a single edge dislocation with a dipole constituent + - (2.0_pReal*prm%minDipDistance)/prm%burgers*stt%rhoEdgeDip(:,of)*abs(dot%accshear(:,of)) & !* Spontaneous annihilation of a single edge dislocation with a dipole constituent - DotRhoEdgeDipClimb end associate @@ -558,7 +557,7 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe integer(pInt) :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos,gdot_slip_neg + gdot_pos,gdot_neg c = 0_pInt @@ -572,10 +571,10 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe case (rhoDip_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) case (shearrate_ID) - call kinetics(Mp,Temperature,instance,of,gdot_slip_pos,gdot_slip_neg) - postResults(c+1:c+prm%totalNslip) = gdot_slip_pos + gdot_slip_neg + call kinetics(Mp,Temperature,instance,of,gdot_pos,gdot_neg) + postResults(c+1:c+prm%totalNslip) = gdot_pos + gdot_neg case (accumulatedshear_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip, of) + postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear(1_pInt:prm%totalNslip, of) case (mfp_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%mfp(1_pInt:prm%totalNslip, of) case (thresholdstress_ID) @@ -610,7 +609,7 @@ end function plastic_disloUCLA_postResults ! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- pure subroutine kinetics(Mp,Temperature,instance,of, & - gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg,tau_slip_pos1,tau_slip_neg1) + gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg,tau_pos1,tau_neg1) use prec, only: & tol_math_check, & dEq, dNeq0 @@ -628,119 +627,119 @@ pure subroutine kinetics(Mp,Temperature,instance,of, & of real(pReal), intent(out), dimension(param(instance)%totalNslip) :: & - gdot_slip_pos, & - gdot_slip_neg + gdot_pos, & + gdot_neg real(pReal), intent(out), optional, dimension(param(instance)%totalNslip) :: & - dgdot_dtauslip_pos, & - dgdot_dtauslip_neg, & - tau_slip_pos1, & - tau_slip_neg1 + dgdot_dtau_pos, & + dgdot_dtau_neg, & + tau_pos1, & + tau_neg1 real(pReal), dimension(param(instance)%totalNslip) :: & StressRatio, & StressRatio_p,StressRatio_pminus1, & - dvel_slip, vel_slip, & - tau_slip_pos,tau_slip_neg, & + dvel, vel, & + tau_pos,tau_neg, & needsGoodName ! ToDo: @Karo: any idea? integer(pInt) :: j associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do j = 1_pInt, prm%totalNslip - tau_slip_pos(j) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,j)) - tau_slip_neg(j) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,j)) + tau_pos(j) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,j)) + tau_neg(j) = math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,j)) enddo - if (present(tau_slip_pos1)) tau_slip_pos1 = tau_slip_pos - if (present(tau_slip_neg1)) tau_slip_neg1 = tau_slip_neg + if (present(tau_pos1)) tau_pos1 = tau_pos + if (present(tau_neg1)) tau_neg1 = tau_neg associate(BoltzmannRatio => prm%H0kp/(kB*Temperature), & DotGamma0 => stt%rhoEdge(:,of)*prm%burgers*prm%v0, & effectiveLength => dst%mfp(:,of) - prm%w) - significantPositiveTau: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_pos)-dst%threshold_stress(:,of))/prm%tau0 + significantPositiveTau: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check) + StressRatio = (abs(tau_pos)-dst%threshold_stress(:,of))/prm%tau0 StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) - vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * effectiveLength * tau_slip_pos * needsGoodName & - / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + vel = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * effectiveLength * tau_pos * needsGoodName & + / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_pos & + prm%omega * prm%B * effectiveLength**2.0_pReal* needsGoodName & ) - gdot_slip_pos = DotGamma0 * sign(vel_slip,tau_slip_pos) * 0.5_pReal + gdot_pos = DotGamma0 * sign(vel,tau_pos) * 0.5_pReal else where significantPositiveTau - gdot_slip_pos = 0.0_pReal + gdot_pos = 0.0_pReal end where significantPositiveTau - if (present(dgdot_dtauslip_pos)) then - significantPositiveTau2: where(abs(tau_slip_pos)-dst%threshold_stress(:,of) > tol_math_check) - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & + if (present(dgdot_dtau_pos)) then + significantPositiveTau2: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check) + dvel = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & * ( & - (needsGoodName + tau_slip_pos * abs(needsGoodName)*BoltzmannRatio*prm%p & + (needsGoodName + tau_pos * abs(needsGoodName)*BoltzmannRatio*prm%p & * prm%q/prm%tau0 & * StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) & ) & - * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_pos & + * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_pos & + prm%omega * prm%B* effectiveLength **2.0_pReal* needsGoodName & ) & - - tau_slip_pos * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + - tau_pos * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + prm%omega * prm%B *effectiveLength **2.0_pReal& * (abs(needsGoodName)*BoltzmannRatio*prm%p *prm%q/prm%tau0 & *StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& ) & ) & - /(2.0_pReal*prm%burgers**2.0_pReal*tau_slip_pos & + /(2.0_pReal*prm%burgers**2.0_pReal*tau_pos & + prm%omega * prm%B* effectiveLength**2.0_pReal* needsGoodName )**2.0_pReal - dgdot_dtauslip_pos = DotGamma0 * dvel_slip* 0.5_pReal + dgdot_dtau_pos = DotGamma0 * dvel* 0.5_pReal else where significantPositiveTau2 - dgdot_dtauslip_pos = 0.0_pReal + dgdot_dtau_pos = 0.0_pReal end where significantPositiveTau2 endif - significantNegativeTau: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) - StressRatio = (abs(tau_slip_neg)-dst%threshold_stress(:,of))/prm%tau0 + significantNegativeTau: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check) + StressRatio = (abs(tau_neg)-dst%threshold_stress(:,of))/prm%tau0 StressRatio_p = StressRatio** prm%p StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) needsGoodName = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q) - vel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & - * effectiveLength * tau_slip_neg * needsGoodName & - / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + vel = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega & + * effectiveLength * tau_neg * needsGoodName & + / ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_neg & + prm%omega * prm%B * effectiveLength**2.0_pReal* needsGoodName & ) - gdot_slip_neg = DotGamma0 * sign(vel_slip,tau_slip_neg) * 0.5_pReal + gdot_neg = DotGamma0 * sign(vel,tau_neg) * 0.5_pReal else where significantNegativeTau - gdot_slip_neg = 0.0_pReal + gdot_neg = 0.0_pReal end where significantNegativeTau - if (present(dgdot_dtauslip_neg)) then - significantNegativeTau2: where(abs(tau_slip_neg)-dst%threshold_stress(:,of) > tol_math_check) - dvel_slip = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & + if (present(dgdot_dtau_neg)) then + significantNegativeTau2: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check) + dvel = 2.0_pReal*prm%burgers * prm%kink_height * prm%omega* effectiveLength & * ( & - (needsGoodName + tau_slip_neg * abs(needsGoodName)*BoltzmannRatio*prm%p & + (needsGoodName + tau_neg * abs(needsGoodName)*BoltzmannRatio*prm%p & * prm%q/prm%tau0 & * StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) & ) & - * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_slip_neg & + * ( 2.0_pReal*(prm%burgers**2.0_pReal)*tau_neg & + prm%omega * prm%B* effectiveLength **2.0_pReal* needsGoodName & ) & - - tau_slip_neg * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + - tau_neg * needsGoodName * (2.0_pReal*prm%burgers**2.0_pReal & + prm%omega * prm%B *effectiveLength **2.0_pReal& * (abs(needsGoodName)*BoltzmannRatio*prm%p *prm%q/prm%tau0 & *StressRatio_pminus1*(1-StressRatio_p)**(prm%q-1.0_pReal) )& ) & ) & - /(2.0_pReal*prm%burgers**2.0_pReal*tau_slip_neg & + /(2.0_pReal*prm%burgers**2.0_pReal*tau_neg & + prm%omega * prm%B* effectiveLength**2.0_pReal* needsGoodName )**2.0_pReal - dgdot_dtauslip_neg = DotGamma0 * dvel_slip * 0.5_pReal + dgdot_dtau_neg = DotGamma0 * dvel * 0.5_pReal else where significantNegativeTau2 - dgdot_dtauslip_neg = 0.0_pReal + dgdot_dtau_neg = 0.0_pReal end where significantNegativeTau2 end if end associate diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 8576d5425..fe7fa5ef1 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -32,24 +32,23 @@ module plastic_kinehardening type, private :: tParameters real(pReal) :: & - gdot0, & !< reference shear strain rate for slip (input parameter) - n_slip, & !< stress exponent for slip (input parameter) + gdot0, & !< reference shear strain rate for slip + n, & !< stress exponent for slip aTolResistance, & aTolShear real(pReal), allocatable, dimension(:) :: & - crss0, & !< initial critical shear stress for slip (input parameter, per family) + 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 > - theta0_b, & !< initial hardening rate of back stress for each slip > - theta1_b, & !< asymptotic hardening rate of back stress for each slip > + theta1, & !< asymptotic hardening rate of forward stress for each slip + theta0_b, & !< initial hardening rate of back stress for each slip + theta1_b, & !< asymptotic hardening rate of back stress for each slip tau1, & tau1_b, & nonSchmidCoeff real(pReal), allocatable, dimension(:,:) :: & interaction_slipslip !< slip resistance from slip activity real(pReal), allocatable, dimension(:,:,:) :: & - Schmid_slip, & - Schmid_twin, & + Schmid, & nonSchmid_pos, & nonSchmid_neg integer(pInt) :: & @@ -203,16 +202,16 @@ subroutine plastic_kinehardening_init prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config%getFloat('c/a',defaultVal=0.0_pReal)) + prm%Schmid = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& + config%getFloat('c/a',defaultVal=0.0_pReal)) if(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) else - prm%nonSchmid_pos = prm%Schmid_slip - prm%nonSchmid_neg = prm%Schmid_slip + prm%nonSchmid_pos = prm%Schmid + prm%nonSchmid_neg = prm%Schmid endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & @@ -227,7 +226,7 @@ subroutine plastic_kinehardening_init prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) prm%gdot0 = config%getFloat('gdot0') - prm%n_slip = config%getFloat('n_slip') + prm%n = config%getFloat('n_slip') ! expand: family => system prm%crss0 = math_expand(prm%crss0, prm%Nslip) @@ -242,8 +241,8 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! sanity checks - if ( prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if ( prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if ( prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if ( prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (any(prm%crss0 <= 0.0_pReal)) extmsg = trim(extmsg)//' crss0' if (any(prm%tau1 <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' if (any(prm%tau1_b <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' @@ -384,11 +383,11 @@ 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 - Lp = Lp + (gdot_pos(i)+gdot_neg(i))*prm%Schmid_slip(1:3,1:3,i) + 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) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & - + dgdot_dtau_pos(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_pos(m,n,i) & - + dgdot_dtau_neg(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_neg(m,n,i) + + 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) enddo end associate @@ -546,7 +545,7 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg case (resolvedstress_ID) do i = 1_pInt, prm%totalNslip - postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) + postResults(c+i) = math_mul33xx33(Mp,prm%Schmid(1:3,1:3,i)) enddo end select @@ -605,28 +604,28 @@ pure subroutine kinetics(Mp,instance,of, & where(dNeq0(tau_pos)) gdot_pos = prm%gdot0 * merge(0.5_pReal,1.0_pReal, nonSchmidActive) & ! 1/2 if non-Schmid active - * sign(abs(tau_pos/stt%crss(:,of))**prm%n_slip, tau_pos) + * sign(abs(tau_pos/stt%crss(:,of))**prm%n, tau_pos) else where gdot_pos = 0.0_pReal end where where(dNeq0(tau_neg)) gdot_neg = prm%gdot0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 - * sign(abs(tau_neg/stt%crss(:,of))**prm%n_slip, tau_neg) + * sign(abs(tau_neg/stt%crss(:,of))**prm%n, tau_neg) else where gdot_neg = 0.0_pReal end where if (present(dgdot_dtau_pos)) then where(dNeq0(gdot_pos)) - dgdot_dtau_pos = gdot_pos*prm%n_slip/tau_pos + dgdot_dtau_pos = gdot_pos*prm%n/tau_pos else where dgdot_dtau_pos = 0.0_pReal end where endif if (present(dgdot_dtau_neg)) then where(dNeq0(gdot_neg)) - dgdot_dtau_neg = gdot_neg*prm%n_slip/tau_neg + dgdot_dtau_neg = gdot_neg*prm%n/tau_neg else where dgdot_dtau_neg = 0.0_pReal end where From 13c64d79a5bbd500aceca91cbea4ff4c1993970b Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 7 Jan 2019 21:51:08 +0100 Subject: [PATCH 193/372] [skip ci] updated version information after successful test of v2.0.2-1347-gd0a06607 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 6efd0b994..f9287287d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1291-g19df6f8a +v2.0.2-1347-gd0a06607 From 8f18581b91ad244194b73043fff2364bc87edbb2 Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 8 Jan 2019 05:25:01 +0100 Subject: [PATCH 194/372] [skip ci] updated version information after successful test of v2.0.2-1389-g070952db --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index f9287287d..87227cb88 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1347-gd0a06607 +v2.0.2-1389-g070952db From 0dca8d2740e136c3eb526f8295cdb76a071eaed2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 9 Jan 2019 16:28:21 +0100 Subject: [PATCH 195/372] compatible to python 3 and mentat >= 2017 --- processing/pre/mentat_pbcOnBoxMesh.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/processing/pre/mentat_pbcOnBoxMesh.py b/processing/pre/mentat_pbcOnBoxMesh.py index afd8d95f0..c171c6ccd 100755 --- a/processing/pre/mentat_pbcOnBoxMesh.py +++ b/processing/pre/mentat_pbcOnBoxMesh.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import sys,os,re,time,tempfile @@ -93,7 +93,7 @@ def add_servoLinks(mfd_data,active=[True,True,True]): # directions on which to for i in range(len(mfd_data)): mfd_dict[mfd_data[i]['label']] = i - NodeCoords = np.array(mfd_data[mfd_dict['nodes']]['els'][0::4])[:,1:4] + NodeCoords = np.array(mfd_data[mfd_dict['nodes']]['els'][1::4])[:,1:4] Nnodes = NodeCoords.shape[0] box['min'] = NodeCoords.min(axis=0) # find the bounding box From c5dabbb68f0258cab3c9eb3b4a79c0b4aa893103 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 9 Jan 2019 16:29:59 +0100 Subject: [PATCH 196/372] correct comment sign the # indicates the end of a list --- processing/pre/mentat_spectralBox.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/processing/pre/mentat_spectralBox.py b/processing/pre/mentat_spectralBox.py index aa7039e0d..89f4a7a43 100755 --- a/processing/pre/mentat_spectralBox.py +++ b/processing/pre/mentat_spectralBox.py @@ -49,7 +49,7 @@ def output(cmds,locals,dest): #------------------------------------------------------------------------------------------------- def init(): return [ - "#"+' '.join([scriptID] + sys.argv[1:]), + "|"+' '.join([scriptID] + sys.argv[1:]), "*draw_manual", # prevent redrawing in Mentat, should be much faster "*new_model yes", "*reset", From a2a3aa7da895971029437abb1202af36c5f7d32e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 9 Jan 2019 16:53:05 +0100 Subject: [PATCH 197/372] new tests for MSC.Marc tools --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 59b0cbe89..6e7550042 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 59b0cbe899f272476fb6f00f0f8860428e6ceba3 +Subproject commit 6e7550042259f46992329d202f5804df48ce99ff From 1173780c530f25733f3f84de2ec39c6a6bd1ec83 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 9 Jan 2019 21:05:52 +0100 Subject: [PATCH 198/372] [skip ci] updated version information after successful test of v2.0.2-1393-ga2a3aa7d --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 87227cb88..fec1fdb0e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1389-g070952db +v2.0.2-1393-ga2a3aa7d From 4848e600dae95a07b271e247a2cec8d1b4c1fd78 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 10 Jan 2019 22:57:36 +0100 Subject: [PATCH 199/372] test failed because DAMASK version in comment was not ignored --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 6e7550042..5ed6a1f60 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 6e7550042259f46992329d202f5804df48ce99ff +Subproject commit 5ed6a1f60b412eb46ff6820cf03b684095ff1f75 From 808ac2c73986f25917df14e58a5009801bf45c71 Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 11 Jan 2019 03:11:19 +0100 Subject: [PATCH 200/372] [skip ci] updated version information after successful test of v2.0.2-1395-g4848e600 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index fec1fdb0e..895c5d6b5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1393-ga2a3aa7d +v2.0.2-1395-g4848e600 From e43057adb389d3ae9204268c043e9c939fe29909 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 12 Jan 2019 22:04:03 +0100 Subject: [PATCH 201/372] cleaning --- src/homogenization_RGC.f90 | 201 ++++++++++++++++--------------- src/homogenization_isostrain.f90 | 50 ++++---- src/homogenization_none.f90 | 14 ++- 3 files changed, 142 insertions(+), 123 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 8e331c185..45fd078fb 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -19,19 +19,17 @@ module homogenization_RGC homogenization_RGC_output ! name of each post result output enum, bind(c) - enumerator :: undefined_ID, & - constitutivework_ID, & - penaltyenergy_ID, & - volumediscrepancy_ID, & - averagerelaxrate_ID,& - maximumrelaxrate_ID,& - ipcoords_ID,& - magnitudemismatch_ID,& - avgdefgrad_ID,& - avgfirstpiola_ID + enumerator :: & + undefined_ID, & + constitutivework_ID, & + penaltyenergy_ID, & + volumediscrepancy_ID, & + averagerelaxrate_ID,& + maximumrelaxrate_ID,& + magnitudemismatch_ID end enum - type, private :: tParameters !< container type for internal constitutive parameters + type, private :: tParameters integer(pInt), dimension(:), allocatable :: & Nconstituents real(pReal) :: & @@ -40,8 +38,10 @@ module homogenization_RGC real(pReal), dimension(:), allocatable :: & dAlpha, & angles + integer(pInt) :: & + of_debug integer(kind(undefined_ID)), dimension(:), allocatable :: & - outputID !< ID of each post result output + outputID end type type, private :: tRGCstate @@ -61,8 +61,8 @@ module homogenization_RGC orientation end type tRGCdependentState - type(tparameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) - type(tRGCstate), dimension(:), allocatable, private :: state + type(tparameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) + type(tRGCstate), dimension(:), allocatable, private :: state type(tRGCdependentState), dimension(:), allocatable, private :: dependentState public :: & @@ -102,25 +102,27 @@ subroutine homogenization_RGC_init() use math, only: & math_EulerToR,& INRAD - use mesh, only: & - mesh_NcpElems,& - mesh_NipsPerElem - use IO + use IO, only: & + IO_error, & + IO_timeStamp use material - use config + use config, only: & + config_homogenization implicit none integer(pInt) :: & - NofMyHomog, & - h, & - outputSize, & - instance, & - sizeHState, nIntFaceTot - integer(pInt) :: maxNinstance, i,j,e, of + Ninstance, & + h, i, j, & + NofMyHomog, outputSize, & + sizeState, nIntFaceTot + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - integer(kind(undefined_ID)) :: & - outputID !< ID of each post result output - character(len=65536), dimension(:), allocatable :: outputs + + integer(kind(undefined_ID)) :: & + outputID + + character(len=65536), dimension(:), allocatable :: & + outputs write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_RGC_label//' init -+>>>' write(6,'(/,a)') ' Tjahjanto et al., International Journal of Material Forming, 2(1):939–942, 2009' @@ -130,39 +132,47 @@ subroutine homogenization_RGC_init() write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - maxNinstance = int(count(homogenization_type == HOMOGENIZATION_RGC_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(homogenization_type == HOMOGENIZATION_RGC_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(param(maxNinstance)) ! one container of parameters per instance - allocate(state(maxNinstance)) ! one container per instance - allocate(dependentState(maxNinstance)) ! one container per instance - - allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) - homogenization_RGC_output='' - allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& - source=0_pInt) + allocate(param(Ninstance)) + allocate(state(Ninstance)) + allocate(dependentState(Ninstance)) + + allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0_pInt) + allocate(homogenization_RGC_output(maxval(homogenization_Noutput),Ninstance)) + homogenization_RGC_output='' do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle - instance = homogenization_typeInstance(h) - associate(prm => param(instance)) + associate(prm => param(homogenization_typeInstance(h)), & + stt => state(homogenization_typeInstance(h)), & + dst => dependentState(homogenization_typeInstance(h)), & + config => config_homogenization(h)) + +#ifdef DEBUG + if (h==material_homogenizationAt(debug_e)) then + prm%of_debug = mappingHomogenization(1,debug_i,debug_e) + endif +#endif - prm%Nconstituents = config_homogenization(h)%getInts('clustersize',requiredShape=[3]) + prm%Nconstituents = config%getInts('clustersize',requiredShape=[3]) if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') - prm%xiAlpha = config_homogenization(h)%getFloat('scalingparameter') - prm%ciAlpha = config_homogenization(h)%getFloat('overproportionality') - prm%dAlpha = config_homogenization(h)%getFloats('grainsize',requiredShape=[3]) - prm%angles = config_homogenization(h)%getFloats('clusterorientation',requiredShape=[3]) + prm%xiAlpha = config%getFloat('scalingparameter') + prm%ciAlpha = config%getFloat('overproportionality') + prm%dAlpha = config%getFloats('grainsize',requiredShape=[3]) + prm%angles = config%getFloats('clusterorientation',requiredShape=[3]) - outputs = config_homogenization(h)%getStrings('(output)',defaultVal=emptyStringArray) + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) do i=1_pInt, size(outputs) outputID = undefined_ID select case(outputs(i)) + case('constitutivework') outputID = constitutivework_ID outputSize = 1_pInt @@ -181,17 +191,19 @@ subroutine homogenization_RGC_init() case('magnitudemismatch') outputID = magnitudemismatch_ID outputSize = 3_pInt - case default + end select + if (outputID /= undefined_ID) then - homogenization_RGC_output(i,instance) = outputs(i) - homogenization_RGC_sizePostResult(i,instance) = outputSize + homogenization_RGC_output(i,homogenization_typeInstance(h)) = outputs(i) + homogenization_RGC_sizePostResult(i,homogenization_typeInstance(h)) = outputSize prm%outputID = [prm%outputID , outputID] endif + enddo if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - write(6,'(a15,1x,i4,/)') 'instance: ', instance + write(6,'(a15,1x,i4,/)') 'instance: ', homogenization_typeInstance(h) write(6,'(a25,3(1x,i8))') 'cluster size: ',(prm%Nconstituents(j),j=1_pInt,3_pInt) write(6,'(a25,1x,e10.3)') 'scaling parameter: ', prm%xiAlpha write(6,'(a25,1x,e10.3)') 'over-proportionality: ', prm%ciAlpha @@ -203,38 +215,36 @@ subroutine homogenization_RGC_init() nIntFaceTot = 3_pInt*( (prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt)) - sizeHState = nIntFaceTot & - + 8_pInt ! (1) Average constitutive work, (2-4) Overall mismatch, (5) Average penalty energy, - ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component - - homogState(h)%sizeState = sizeHState - homogState(h)%sizePostResults = sum(homogenization_RGC_sizePostResult(:,instance)) - allocate(homogState(h)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) - allocate(homogState(h)%state (sizeHState,NofMyHomog), source=0.0_pReal) + sizeState = nIntFaceTot & + + size(['avg constitutive work']) + size(['overall mismatch']) * 3_pInt & + + size(['average penalty energy ','volume discrepancy ',& + 'avg relaxation rate component ','max relaxation rate componenty']) - state(instance)%relaxationVector => homogState(h)%state(1:nIntFaceTot,:) - state(instance)%work => homogState(h)%state(nIntFaceTot+1,:) - state(instance)%mismatch => homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) - state(instance)%penaltyEnergy => homogState(h)%state(nIntFaceTot+5,:) - state(instance)%volumeDiscrepancy => homogState(h)%state(nIntFaceTot+6,:) - state(instance)%relaxationRate_avg => homogState(h)%state(nIntFaceTot+7,:) - state(instance)%relaxationRate_max => homogState(h)%state(nIntFaceTot+8,:) + homogState(h)%sizeState = sizeState + homogState(h)%sizePostResults = sum(homogenization_RGC_sizePostResult(:,homogenization_typeInstance(h))) + allocate(homogState(h)%state0 (sizeState,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%subState0(sizeState,NofMyHomog), source=0.0_pReal) + allocate(homogState(h)%state (sizeState,NofMyHomog), source=0.0_pReal) - allocate(dependentState(instance)%orientation(3,3,NofMyHomog)) + stt%relaxationVector => homogState(h)%state(1:nIntFaceTot,:) + stt%work => homogState(h)%state(nIntFaceTot+1,:) + stt%mismatch => homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) + stt%penaltyEnergy => homogState(h)%state(nIntFaceTot+5,:) + stt%volumeDiscrepancy => homogState(h)%state(nIntFaceTot+6,:) + stt%relaxationRate_avg => homogState(h)%state(nIntFaceTot+7,:) + stt%relaxationRate_max => homogState(h)%state(nIntFaceTot+8,:) + + allocate(dst%orientation(3,3,NofMyHomog)) !-------------------------------------------------------------------------------------------------- -! * assigning cluster orientations - elementLooping: do e = 1_pInt,mesh_NcpElems - if (homogenization_typeInstance(material_homogenizationAt(e)) == instance .and. NofMyHomog > 0_pInt) then - do i = 1_pInt,mesh_NipsPerElem - of = mappingHomogenization(1,i,e) - dependentState(instance)%orientation(1:3,1:3,of) = math_EulerToR(prm%angles*inRad) - enddo - endif - enddo elementLooping +! assigning cluster orientations + do j=1, NofMyHomog + dst%orientation(1:3,1:3,j) = math_EulerToR(prm%angles*inRad) !ToDo: use spread + enddo + end associate + enddo end subroutine homogenization_RGC_init @@ -244,19 +254,23 @@ end subroutine homogenization_RGC_init !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) +#ifdef DEBUG use debug, only: & debug_level, & debug_homogenization, & debug_levelExtensive +#endif use material, only: & homogenization_maxNgrains implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain + real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F integer(pInt), intent(in) :: & instance, & - of !< element number + of + real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 @@ -265,6 +279,7 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations associate(prm => param(instance)) + F = 0.0_pReal do iGrain = 1_pInt,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) @@ -279,18 +294,18 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) !-------------------------------------------------------------------------------------------------- ! debugging the grain deformation gradients +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a32,1x,i3)')'Deformation gradient of grain: ',iGrain do i = 1_pInt,3_pInt write(6,'(1x,3(e15.8,1x))')(F(i,j,iGrain), j = 1_pInt,3_pInt) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif - +#endif enddo + end associate end subroutine homogenization_RGC_partitionDeformation @@ -378,17 +393,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) relax = homogState(mappingHomogenization(2,ip,el))%state (1:3_pInt*nIntFaceTot,of) drelax = relax & - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,of) -!-------------------------------------------------------------------------------------------------- -! debugging the obtained state + +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Obtained state: ' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,of) enddo write(6,*)' ' - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! computing interface mismatch and stress penalty tensor for all interfaces of all grains @@ -398,10 +412,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! calculating volume discrepancy and stress penalty related to overall volume discrepancy call volumePenalty(D,volDiscrep,F,avgF,ip,el) -!-------------------------------------------------------------------------------------------------- -! debugging the mismatch, stress and penalties of grains +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) do iGrain = 1_pInt,nGrain write(6,'(1x,a30,1x,i3,1x,a4,3(1x,e15.8))')'Mismatch magnitude of grain(',iGrain,') :',& NN(1,iGrain),NN(2,iGrain),NN(3,iGrain) @@ -413,8 +425,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo write(6,*)' ' enddo - !$OMP END CRITICAL (write2out) endif +#endif !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces @@ -448,15 +460,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo enddo -!-------------------------------------------------------------------------------------------------- -! debugging the residual stress +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30,1x,i3)')'Traction at interface: ',iNum write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1_pInt,3_pInt) write(6,*)' ' - !$OMP END CRITICAL (write2out) endif +#endif enddo !-------------------------------------------------------------------------------------------------- @@ -466,8 +476,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) residMax = maxval(abs(tract)) ! get the maximum of the residual residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual -!-------------------------------------------------------------------------------------------------- -! Debugging the convergent criteria +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then !$OMP CRITICAL (write2out) @@ -478,8 +487,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2)')'Max residual: ',residMax, & '@ iface',residLoc(1),'in direction',residLoc(2) flush(6) - !$OMP END CRITICAL (write2out) endif +#endif homogenization_RGC_updateState = .false. diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 66acdd5e5..9987b7e61 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -7,12 +7,13 @@ module homogenization_isostrain use prec, only: & pInt - + implicit none private enum, bind(c) - enumerator :: parallel_ID, & - average_ID + enumerator :: & + parallel_ID, & + average_ID end enum type, private :: tParameters !< container type for internal constitutive parameters @@ -59,22 +60,17 @@ subroutine homogenization_isostrain_init() implicit none integer(pInt) :: & - h - integer :: & - Ninstance - integer :: & - NofMyHomog ! no pInt (stores a system dependen value from 'count' + Ninstance, & + h, & + NofMyHomog character(len=65536) :: & tag = '' - type(tParameters) :: prm - + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - Ninstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) - if (Ninstance == 0) return - + Ninstance = int(count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID),pInt) if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance @@ -82,12 +78,13 @@ subroutine homogenization_isostrain_init() do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle - associate(prm => param(homogenization_typeInstance(h))) + + associate(prm => param(homogenization_typeInstance(h)),& + config => config_homogenization(h)) prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') tag = 'sum' - tag = config_homogenization(h)%getString('mapping',defaultVal = tag) - select case(trim(tag)) + select case(trim(config%getString('mapping',defaultVal = tag))) case ('sum') prm%mapping = parallel_ID case ('avg') @@ -97,12 +94,12 @@ subroutine homogenization_isostrain_init() end select NofMyHomog = count(material_homog == h) - homogState(h)%sizeState = 0_pInt homogState(h)%sizePostResults = 0_pInt allocate(homogState(h)%state0 (0_pInt,NofMyHomog)) allocate(homogState(h)%subState0(0_pInt,NofMyHomog)) allocate(homogState(h)%state (0_pInt,NofMyHomog)) + end associate enddo @@ -120,16 +117,18 @@ subroutine homogenization_isostrain_partitionDeformation(F,avgF,instance) homogenization_maxNgrains implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned def grad per grain - real(pReal), dimension (3,3), intent(in) :: avgF !< my average def grad + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partitioned deformation gradient + + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point integer(pInt), intent(in) :: instance - type(tParameters) :: & - prm + associate(prm => param(instance)) + F(1:3,1:3,1:prm%Nconstituents) = spread(avgF,3,prm%Nconstituents) if (homogenization_maxNgrains > prm%Nconstituents) & F(1:3,1:3,prm%Nconstituents+1_pInt:homogenization_maxNgrains) = 0.0_pReal + end associate end subroutine homogenization_isostrain_partitionDeformation @@ -147,13 +146,13 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P implicit none real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses - real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses + + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< partitioned stresses + real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< partitioned stiffnesses integer(pInt), intent(in) :: instance - type(tParameters) :: & - prm associate(prm => param(instance)) + select case (prm%mapping) case (parallel_ID) avgP = sum(P,3) @@ -162,6 +161,7 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P avgP = sum(P,3) /real(prm%Nconstituents,pReal) dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) end select + end associate end subroutine homogenization_isostrain_averageStressAndItsTangent diff --git a/src/homogenization_none.f90 b/src/homogenization_none.f90 index ebff9cdc9..04ea55abe 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_none.f90 @@ -2,7 +2,7 @@ !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief dummy homogenization homogenization scheme +!> @brief dummy homogenization homogenization scheme for 1 constituent per material point !-------------------------------------------------------------------------------------------------- module homogenization_none @@ -24,9 +24,14 @@ subroutine homogenization_none_init() compiler_options #endif use prec, only: & - pInt + pInt + use debug, only: & + debug_HOMOGENIZATION, & + debug_level, & + debug_levelBasic use IO, only: & IO_timeStamp + use material, only: & homogenization_type, & material_homog, & @@ -36,6 +41,7 @@ subroutine homogenization_none_init() implicit none integer(pInt) :: & + Ninstance, & h, & NofMyHomog @@ -43,6 +49,10 @@ subroutine homogenization_none_init() write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" + Ninstance = int(count(homogenization_type == HOMOGENIZATION_NONE_ID),pInt) + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + do h = 1_pInt, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_NONE_ID) cycle From 837699e6c12aa59ea3c694bdaff06e3adf6b77a2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 12 Jan 2019 23:07:35 +0100 Subject: [PATCH 202/372] polishing --- src/homogenization.f90 | 31 ++-- src/homogenization_RGC.f90 | 287 +++++++++++++++++++------------------ 2 files changed, 164 insertions(+), 154 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 32b033ffe..3f62ffd7d 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -922,6 +922,8 @@ function homogenization_postResults(ip,el) use mesh, only: & mesh_element use material, only: & + material_homogenizationAt, & + homogenization_typeInstance,& mappingHomogenization, & homogState, & thermalState, & @@ -958,45 +960,42 @@ function homogenization_postResults(ip,el) + damageState (mappingHomogenization(2,ip,el))%sizePostResults) :: & homogenization_postResults integer(pInt) :: & - startPos, endPos + startPos, endPos ,& + of, instance + homogenization_postResults = 0.0_pReal - startPos = 1_pInt endPos = homogState(mappingHomogenization(2,ip,el))%sizePostResults chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) - case (HOMOGENIZATION_NONE_ID,HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization case (HOMOGENIZATION_RGC_ID) chosenHomogenization - homogenization_postResults(startPos:endPos) = & - homogenization_RGC_postResults(ip,el) + instance = homogenization_typeInstance(material_homogenizationAt(el)) + of = mappingHomogenization(1,ip,el) + homogenization_postResults(startPos:endPos) = homogenization_RGC_postResults(instance,of) + end select chosenHomogenization startPos = endPos + 1_pInt endPos = endPos + thermalState(mappingHomogenization(2,ip,el))%sizePostResults chosenThermal: select case (thermal_type(mesh_element(3,el))) - case (THERMAL_isothermal_ID) chosenThermal case (THERMAL_adiabatic_ID) chosenThermal - homogenization_postResults(startPos:endPos) = & - thermal_adiabatic_postResults(ip, el) + homogenization_postResults(startPos:endPos) = thermal_adiabatic_postResults(ip, el) case (THERMAL_conduction_ID) chosenThermal - homogenization_postResults(startPos:endPos) = & - thermal_conduction_postResults(ip, el) + homogenization_postResults(startPos:endPos) = thermal_conduction_postResults(ip, el) + end select chosenThermal startPos = endPos + 1_pInt endPos = endPos + damageState(mappingHomogenization(2,ip,el))%sizePostResults chosenDamage: select case (damage_type(mesh_element(3,el))) - case (DAMAGE_none_ID) chosenDamage case (DAMAGE_local_ID) chosenDamage - homogenization_postResults(startPos:endPos) = & - damage_local_postResults(ip, el) - + homogenization_postResults(startPos:endPos) = damage_local_postResults(ip, el) case (DAMAGE_nonlocal_ID) chosenDamage - homogenization_postResults(startPos:endPos) = & - damage_nonlocal_postResults(ip, el) + homogenization_postResults(startPos:endPos) = damage_nonlocal_postResults(ip, el) + end select chosenDamage end function homogenization_postResults diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 45fd078fb..7374abcd8 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -39,7 +39,7 @@ module homogenization_RGC dAlpha, & angles integer(pInt) :: & - of_debug + of_debug = 0_pInt integer(kind(undefined_ID)), dimension(:), allocatable :: & outputID end type @@ -133,7 +133,6 @@ subroutine homogenization_RGC_init() #include "compilation_info.f90" Ninstance = int(count(homogenization_type == HOMOGENIZATION_RGC_ID),pInt) - if (Ninstance == 0_pInt) return if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance @@ -318,12 +317,14 @@ end subroutine homogenization_RGC_partitionDeformation function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) use prec, only: & dEq0 +#ifdef DEBUG use debug, only: & debug_level, & debug_homogenization,& debug_levelExtensive, & debug_e, & debug_i +#endif use math, only: & math_invert use material, only: & @@ -363,9 +364,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), dimension (2) :: residLoc integer(pInt) instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of real(pReal), dimension (3,3,homogenization_maxNgrains) :: R,pF,pR,D,pD - real(pReal), dimension (3,homogenization_maxNgrains) :: NN,pNN + real(pReal), dimension (3,homogenization_maxNgrains) :: NN,devNull33 real(pReal), dimension (3) :: normP,normN,mornP,mornN - real(pReal) :: residMax,stresMax,volDiscrep + real(pReal) :: residMax,stresMax,devNull logical error real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix @@ -376,12 +377,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) return endif zeroTimeStep -!-------------------------------------------------------------------------------------------------- -! get the dimension of the cluster (grains and interfaces) + instance = homogenization_typeInstance(material_homogenizationAt(el)) of = mappingHomogenization(1,ip,el) - nGDim = param(instance)%Nconstituents - nGrain = homogenization_Ngrains(material_homogenizationAt(el)) + + associate(stt => state(instance), prm => param(instance)) + +!-------------------------------------------------------------------------------------------------- +! get the dimension of the cluster (grains and interfaces) + nGDim = prm%Nconstituents + nGrain = product(nGDim) nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) @@ -390,15 +395,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) - relax = homogState(mappingHomogenization(2,ip,el))%state (1:3_pInt*nIntFaceTot,of) + relax = stt%relaxationVector(:,of) drelax = relax & - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,of) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then write(6,'(1x,a30)')'Obtained state: ' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,of) + do i = 1_pInt,size(stt%relaxationVector(:,of)) + write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' endif @@ -406,11 +411,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing interface mismatch and stress penalty tensor for all interfaces of all grains - call stressPenalty(R,NN,avgF,F,ip,el,instance) + call stressPenalty(R,NN,avgF,F,ip,el,instance,of) !-------------------------------------------------------------------------------------------------- ! calculating volume discrepancy and stress penalty related to overall volume discrepancy - call volumePenalty(D,volDiscrep,F,avgF,ip,el) + call volumePenalty(D,stt%volumeDiscrepancy(of),avgF,F,nGrain,instance,of) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then @@ -479,7 +484,6 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) write(6,'(1x,a)')' ' write(6,'(1x,a,1x,i2,1x,i4)')'RGC residual check ...',ip,el write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2,i2)')'Max stress: ',stresMax, & @@ -496,45 +500,43 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! If convergence reached => done and happy if (residMax < relTol_RGC*stresMax .or. residMax < absTol_RGC) then homogenization_RGC_updateState = .true. - +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) write(6,'(1x,a55,/)')'... done and happy' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration do iGrain = 1_pInt,homogenization_Ngrains(material_homogenizationAt(el)) ! time-integration loop for work and energy do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt - state(instance)%work(of) = state(instance)%work(of) & - + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) - state(instance)%penaltyEnergy(of) = state(instance)%penaltyEnergy(of) & - + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + stt%work(of) = stt%work(of) & + + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + stt%penaltyEnergy(of) = stt%penaltyEnergy(of) & + + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) enddo; enddo enddo - state(instance)%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) ! the overall mismatch of all interface normals - state(instance)%volumeDiscrepancy(of) = volDiscrep - state(instance)%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) - state(instance)%relaxationRate_max(of) = maxval(abs(drelax))/dt - + stt%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) + stt%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + stt%relaxationRate_max(of) = maxval(abs(drelax))/dt + +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) - write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',state(instance)%work(of) - write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',state(instance)%mismatch(1,of), & - state(instance)%mismatch(2,of), & - state(instance)%mismatch(3,of) - write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ', state(instance)%penaltyEnergy(of) - write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ', state(instance)%volumeDiscrepancy(of) - write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ', state(instance)%relaxationRate_max(of) - write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ', state(instance)%relaxationRate_avg(of) + write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',stt%work(of) + write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',stt%mismatch(1,of), & + stt%mismatch(2,of), & + stt%mismatch(3,of) + write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ', stt%penaltyEnergy(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ', stt%volumeDiscrepancy(of) + write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ', stt%relaxationRate_max(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ', stt%relaxationRate_avg(of) flush(6) - !$OMP END CRITICAL (write2out) endif +#endif return @@ -542,24 +544,25 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! if residual blows-up => done but unhappy elseif (residMax > relMax_RGC*stresMax .or. residMax > absMax_RGC) then ! try to restart when residual blows up exceeding maximum bound homogenization_RGC_updateState = [.true.,.false.] ! with direct cut-back - + +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) write(6,'(1x,a55,/)')'... broken' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif + + return - return else ! proceed with computing the Jacobian and state update +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then - !$OMP CRITICAL (write2out) write(6,'(1x,a55,/)')'... not yet done' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif endif @@ -613,18 +616,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo enddo -!-------------------------------------------------------------------------------------------------- -! debugging the global Jacobian matrix of stress tangent +#ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of stress' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,100(e11.4,1x))')(smatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical @@ -636,10 +637,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do ipert = 1_pInt,3_pInt*nIntFaceTot p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector - homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = p_relax + stt%relaxationVector(:,of) = p_relax call grainDeformation(pF,avgF,instance,of) ! rain deformation from perturbed state - call stressPenalty(pR,pNN,avgF,pF,ip,el,instance) ! stress penalty due to interface mismatch from perturbed state - call volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! stress penalty due to volume discrepancy from perturbed state + call stressPenalty(pR,DevNull33, avgF,pF,ip,el,instance,of) ! stress penalty due to interface mismatch from perturbed state + call volumePenalty(pD,devNull, avgF,pF,nGrain,instance,of) ! stress penalty due to volume discrepancy from perturbed state !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state @@ -675,18 +676,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) pmatrix(:,ipert) = p_resid/pPert_RGC enddo -!-------------------------------------------------------------------------------------------------- -! debugging the global Jacobian matrix of penalty tangent +#ifdef DEBUG if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of penalty' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,100(e11.4,1x))')(pmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! ... of the numerical viscosity traction "rmatrix" @@ -694,54 +693,48 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) forall (i=1_pInt:3_pInt*nIntFaceTot) & rmatrix(i,i) = viscModus_RGC*viscPower_RGC/(refRelaxRate_RGC*dt)* & ! tangent due to numerical viscosity traction appears (abs(drelax(i))/(refRelaxRate_RGC*dt))**(viscPower_RGC - 1.0_pReal) ! only in the main diagonal term - - - -!-------------------------------------------------------------------------------------------------- -! debugging the global Jacobian matrix of numerical viscosity tangent + +#ifdef DEBUG if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix of penalty' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,100(e11.4,1x))')(rmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! The overall Jacobian matrix summarizing contributions of smatrix, pmatrix, rmatrix allocate(jmatrix(3*nIntFaceTot,3*nIntFaceTot)); jmatrix = smatrix + pmatrix + rmatrix - + +#ifdef DEBUG if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian matrix (total)' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,100(e11.4,1x))')(jmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix allocate(jnverse(3_pInt*nIntFaceTot,3_pInt*nIntFaceTot),source=0.0_pReal) call math_invert(size(jmatrix,1),jmatrix,jnverse,error) ! Compute the inverse of the overall Jacobian matrix -!-------------------------------------------------------------------------------------------------- -! debugging the inverse Jacobian matrix +#ifdef DEBUG if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Jacobian inverse' do i = 1_pInt,3_pInt*nIntFaceTot write(6,'(1x,100(e11.4,1x))')(jnverse(i,j), j = 1_pInt,3_pInt*nIntFaceTot) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif !-------------------------------------------------------------------------------------------------- ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration @@ -750,7 +743,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable enddo; enddo relax = relax + drelax ! Updateing the state variable for the next iteration - homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,of) = relax + stt%relaxationVector(:,of) = relax if (any(abs(drelax) > maxdRelax_RGC)) then ! Forcing cutback when the incremental change of relaxation vector becomes too large homogenization_RGC_updateState = [.true.,.false.] !$OMP CRITICAL (write2out) @@ -760,24 +753,24 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !$OMP END CRITICAL (write2out) endif -!-------------------------------------------------------------------------------------------------- -! debugging the return state +#ifdef DEBUG if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then - !$OMP CRITICAL (write2out) write(6,'(1x,a30)')'Returned state: ' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,of) + do i = 1_pInt,size(stt%relaxationVector(:,of)) + write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(:,of) enddo write(6,*)' ' flush(6) - !$OMP END CRITICAL (write2out) endif +#endif + + end associate contains !-------------------------------------------------------------------------------------------------- !> @brief calculate stress-like penalty due to deformation mismatch !-------------------------------------------------------------------------------------------------- - subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance) + subroutine stressPenalty(rPen,nMis,avgF,fDef,ip,el,instance,of) use math, only: & math_civita use numerics, only: & @@ -786,22 +779,23 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen !< stress-like penalty real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el,instance + integer(pInt), intent(in) :: ip,el,instance,of + integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim real(pReal), dimension (3,3) :: gDef,nDef real(pReal), dimension (3) :: nVect,surfCorr real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l,of + integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb real(pReal), parameter :: nDefToler = 1.0e-10_pReal +#ifdef DEBUG logical :: debugActive +#endif - debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip - nGDim = param(instance)%Nconstituents rPen = 0.0_pReal nMis = 0.0_pReal @@ -810,25 +804,29 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! get the correction factor the modulus of penalty stress representing the evolution of area of ! the interfaces due to deformations - of = mappingHomogenization(1,ip,el) surfCorr = surfaceCorrection(avgF,instance,of) + associate(prm => param(instance)) +#ifdef DEBUG + debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. prm%of_debug = of + if (debugActive) then write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el write(6,*) surfCorr endif +#endif !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - do iGrain = 1_pInt,product(prm%Nconstituents) + grainLoop: do iGrain = 1_pInt,product(prm%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position - !* Looping over all six interfaces of each grain - do iFace = 1_pInt,6_pInt + interfaceLoop: do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain nVect = interfaceNormal(intFace,instance,of) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface @@ -854,13 +852,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo; enddo nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) - +#ifdef DEBUG if (debugActive) then write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb write(6,*) transpose(nDef) write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm endif - +#endif + !-------------------------------------------------------------------------------------------------- ! compute the stress penalty of all interfaces do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt; do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt @@ -870,14 +869,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & *tanh(nDefNorm/xSmoo_RGC) enddo; enddo;enddo; enddo - enddo - + enddo interfaceLoop +#ifdef DEBUG if (debugActive) then - write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain - write(6,*) transpose(rPen(1:3,1:3,iGrain)) + write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain + write(6,*) transpose(rPen(1:3,1:3,iGrain)) endif +#endif - enddo + enddo grainLoop + end associate end subroutine stressPenalty @@ -886,7 +887,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- !> @brief calculate stress-like penalty due to volume discrepancy !-------------------------------------------------------------------------------------------------- - subroutine volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) + subroutine volumePenalty(vPen,vDiscrep,fAvg,fDef,nGrain,instance,of) use math, only: & math_det33, & math_inv33 @@ -898,40 +899,41 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen ! stress-like penalty due to volume real(pReal), intent(out) :: vDiscrep ! total volume discrepancy + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef ! deformation gradients real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient - integer(pInt), intent(in) :: ip,& ! integration point - el + integer(pInt), intent(in) :: & + Ngrain, & + instance, & + of + real(pReal), dimension (homogenization_maxNgrains) :: gVol - integer(pInt) :: iGrain,nGrain - logical :: debugActive - - debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip - - nGrain = homogenization_Ngrains(material_homogenizationAt(el)) + integer(pInt) :: i !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster - vDiscrep = math_det33(fAvg) ! compute the volume of the cluster - do iGrain = 1_pInt,nGrain - gVol(iGrain) = math_det33(fDef(1:3,1:3,iGrain)) ! compute the volume of individual grains - vDiscrep = vDiscrep - gVol(iGrain)/real(nGrain,pReal) ! calculate the difference/dicrepancy between - ! the volume of the cluster and the the total volume of grains + vDiscrep = math_det33(fAvg) ! compute the volume of the cluster + do i = 1_pInt,nGrain + gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains + vDiscrep = vDiscrep - gVol(i)/real(nGrain,pReal) ! calculate the difference/dicrepancy between + ! the volume of the cluster and the the total volume of grains enddo !-------------------------------------------------------------------------------------------------- ! calculate the stress and penalty due to volume discrepancy vPen = 0.0_pReal - do iGrain = 1_pInt,nGrain - vPen(:,:,iGrain) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & + do i = 1_pInt,nGrain + vPen(:,:,i) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & - gVol(iGrain)*transpose(math_inv33(fDef(:,:,iGrain))) + gVol(i)*transpose(math_inv33(fDef(:,:,i))) - if (debugActive) then - write(6,'(1x,a30,i2)')'Volume penalty of grain: ',iGrain - write(6,*) transpose(vPen(:,:,iGrain)) +#ifdef DEBUG + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. param(instance)%of_debug == of) then + write(6,'(1x,a30,i2)')'Volume penalty of grain: ',i + write(6,*) transpose(vPen(:,:,i)) endif +#endif enddo end subroutine volumePenalty @@ -1020,6 +1022,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), intent(in) :: & instance, & of + real(pReal), dimension (3) :: aVect,nVect integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3 @@ -1027,9 +1030,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations + + associate(prm => param(instance)) + F = 0.0_pReal - do iGrain = 1_pInt,product(param(instance)%Nconstituents) - iGrain3 = grain1to3(iGrain,param(instance)%Nconstituents) + do iGrain = 1_pInt,product(prm%Nconstituents) + iGrain3 = grain1to3(iGrain,prm%Nconstituents) do iFace = 1_pInt,6_pInt intFace = getInterface(iFace,iGrain3) aVect = relaxationVector(intFace,instance,of) @@ -1040,6 +1046,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient enddo + end associate + end subroutine grainDeformation end function homogenization_RGC_updateState @@ -1068,50 +1076,48 @@ end subroutine homogenization_RGC_averageStressAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of homogenization results for post file inclusion !-------------------------------------------------------------------------------------------------- -pure function homogenization_RGC_postResults(ip,el) result(postResults) - use material, only: & - material_homogenizationAt, & - homogenization_typeInstance,& - mappingHomogenization - +pure function homogenization_RGC_postResults(instance,of) result(postResults) implicit none integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - - integer(pInt) instance,o,c,of - real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,homogenization_typeInstance(material_homogenizationAt(el))))) :: & + instance, & + of + + integer(pInt) :: & + o,c + real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,instance))) :: & postResults - instance = homogenization_typeInstance(material_homogenizationAt(el)) - associate(prm => param(instance)) - of = mappingHomogenization(1,ip,el) + associate(prm => param(instance), stt => state(instance)) c = 0_pInt - postResults = 0.0_pReal + outputsLoop: do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) + case (constitutivework_ID) - postResults(c+1) = state(instance)%work(of) + postResults(c+1) = stt%work(of) c = c + 1_pInt case (magnitudemismatch_ID) - postResults(c+1:c+3) = state(instance)%mismatch(1:3,of) + postResults(c+1:c+3) = stt%mismatch(1:3,of) c = c + 3_pInt case (penaltyenergy_ID) - postResults(c+1) = state(instance)%penaltyEnergy(of) + postResults(c+1) = stt%penaltyEnergy(of) c = c + 1_pInt case (volumediscrepancy_ID) - postResults(c+1) = state(instance)%volumeDiscrepancy(of) + postResults(c+1) = stt%volumeDiscrepancy(of) c = c + 1_pInt case (averagerelaxrate_ID) - postResults(c+1) = state(instance)%relaxationrate_avg(of) + postResults(c+1) = stt%relaxationrate_avg(of) c = c + 1_pInt case (maximumrelaxrate_ID) - postResults(c+1) = state(instance)%relaxationrate_max(of) + postResults(c+1) = stt%relaxationrate_max(of) c = c + 1_pInt end select + enddo outputsLoop + end associate + end function homogenization_RGC_postResults @@ -1122,6 +1128,7 @@ pure function relaxationVector(intFace,instance,of) implicit none integer(pInt), intent(in) :: instance,of + real(pReal), dimension (3) :: relaxationVector integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) integer(pInt) :: & @@ -1129,9 +1136,13 @@ pure function relaxationVector(intFace,instance,of) !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array - relaxationVector = 0.0_pReal + iNum = interface4to1(intFace,param(instance)%Nconstituents) ! identify the position of the interface in global state array - if (iNum > 0_pInt) relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) + if (iNum > 0_pInt) then + relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) + else + relaxationVector = 0.0_pReal + endif end function relaxationVector @@ -1274,7 +1285,7 @@ pure function interface1to4(iFace1D, nGDim) integer(pInt), dimension(4) :: interface1to4 integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array integer(pInt), dimension(3), intent(in) :: nGDim - integer(pInt), dimension (3) :: nIntFace + integer(pInt), dimension(3) :: nIntFace !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... From 7f459e85f182784350a3c6d1fcedf15a47d49ada Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 12 Jan 2019 23:22:13 +0100 Subject: [PATCH 203/372] no need to be real state --- src/homogenization_RGC.f90 | 71 ++++++++++++++++++++------------------ 1 file changed, 37 insertions(+), 34 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 7374abcd8..1448b5a76 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -47,23 +47,28 @@ module homogenization_RGC type, private :: tRGCstate real(pReal), pointer, dimension(:) :: & work, & - penaltyEnergy, & - volumeDiscrepancy, & - relaxationRate_avg, & - relaxationRate_max + penaltyEnergy real(pReal), pointer, dimension(:,:) :: & - relaxationVector, & - mismatch + relaxationVector end type tRGCstate type, private :: tRGCdependentState + real(pReal), allocatable, dimension(:) :: & + volumeDiscrepancy, & + relaxationRate_avg, & + relaxationRate_max + real(pReal), allocatable, dimension(:,:) :: & + mismatch real(pReal), allocatable, dimension(:,:,:) :: & orientation end type tRGCdependentState - type(tparameters), dimension(:), allocatable, private :: param !< containers of parameters (len Ninstance) - type(tRGCstate), dimension(:), allocatable, private :: state - type(tRGCdependentState), dimension(:), allocatable, private :: dependentState + type(tparameters), dimension(:), allocatable, private :: & + param + type(tRGCstate), dimension(:), allocatable, private :: & + state + type(tRGCdependentState), dimension(:), allocatable, private :: & + dependentState public :: & homogenization_RGC_init, & @@ -215,9 +220,7 @@ subroutine homogenization_RGC_init() + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt)) sizeState = nIntFaceTot & - + size(['avg constitutive work']) + size(['overall mismatch']) * 3_pInt & - + size(['average penalty energy ','volume discrepancy ',& - 'avg relaxation rate component ','max relaxation rate componenty']) + + size(['avg constitutive work ','average penalty energy']) homogState(h)%sizeState = sizeState homogState(h)%sizePostResults = sum(homogenization_RGC_sizePostResult(:,homogenization_typeInstance(h))) @@ -227,13 +230,13 @@ subroutine homogenization_RGC_init() stt%relaxationVector => homogState(h)%state(1:nIntFaceTot,:) stt%work => homogState(h)%state(nIntFaceTot+1,:) - stt%mismatch => homogState(h)%state(nIntFaceTot+2:nIntFaceTot+4,:) - stt%penaltyEnergy => homogState(h)%state(nIntFaceTot+5,:) - stt%volumeDiscrepancy => homogState(h)%state(nIntFaceTot+6,:) - stt%relaxationRate_avg => homogState(h)%state(nIntFaceTot+7,:) - stt%relaxationRate_max => homogState(h)%state(nIntFaceTot+8,:) + stt%penaltyEnergy => homogState(h)%state(nIntFaceTot+2,:) - allocate(dst%orientation(3,3,NofMyHomog)) + allocate(dst%volumeDiscrepancy( NofMyHomog)) + allocate(dst%relaxationRate_avg( NofMyHomog)) + allocate(dst%relaxationRate_max( NofMyHomog)) + allocate(dst%mismatch( 3, NofMyHomog)) + allocate(dst%orientation( 3,3,NofMyHomog)) !-------------------------------------------------------------------------------------------------- @@ -381,7 +384,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) instance = homogenization_typeInstance(material_homogenizationAt(el)) of = mappingHomogenization(1,ip,el) - associate(stt => state(instance), prm => param(instance)) + associate(stt => state(instance), dst => dependentState(instance), prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) @@ -415,7 +418,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculating volume discrepancy and stress penalty related to overall volume discrepancy - call volumePenalty(D,stt%volumeDiscrepancy(of),avgF,F,nGrain,instance,of) + call volumePenalty(D,dst%volumeDiscrepancy(of),avgF,F,nGrain,instance,of) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then @@ -519,21 +522,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo; enddo enddo - stt%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) - stt%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) - stt%relaxationRate_max(of) = maxval(abs(drelax))/dt + dst%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) + dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + dst%relaxationRate_max(of) = maxval(abs(drelax))/dt #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',stt%work(of) - write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',stt%mismatch(1,of), & - stt%mismatch(2,of), & - stt%mismatch(3,of) + write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',dst%mismatch(1,of), & + dst%mismatch(2,of), & + dst%mismatch(3,of) write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ', stt%penaltyEnergy(of) - write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ', stt%volumeDiscrepancy(of) - write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ', stt%relaxationRate_max(of) - write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ', stt%relaxationRate_avg(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ', dst%volumeDiscrepancy(of) + write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ', dst%relaxationRate_max(of) + write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ', dst%relaxationRate_avg(of) flush(6) endif #endif @@ -1087,7 +1090,7 @@ pure function homogenization_RGC_postResults(instance,of) result(postResults) real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,instance))) :: & postResults - associate(prm => param(instance), stt => state(instance)) + associate(stt => state(instance), dst => dependentState(instance), prm => param(instance)) c = 0_pInt @@ -1098,19 +1101,19 @@ pure function homogenization_RGC_postResults(instance,of) result(postResults) postResults(c+1) = stt%work(of) c = c + 1_pInt case (magnitudemismatch_ID) - postResults(c+1:c+3) = stt%mismatch(1:3,of) + postResults(c+1:c+3) = dst%mismatch(1:3,of) c = c + 3_pInt case (penaltyenergy_ID) postResults(c+1) = stt%penaltyEnergy(of) c = c + 1_pInt case (volumediscrepancy_ID) - postResults(c+1) = stt%volumeDiscrepancy(of) + postResults(c+1) = dst%volumeDiscrepancy(of) c = c + 1_pInt case (averagerelaxrate_ID) - postResults(c+1) = stt%relaxationrate_avg(of) + postResults(c+1) = dst%relaxationrate_avg(of) c = c + 1_pInt case (maximumrelaxrate_ID) - postResults(c+1) = stt%relaxationrate_max(of) + postResults(c+1) = dst%relaxationrate_max(of) c = c + 1_pInt end select From fe28e0d7396964f49216e0fe8ca4d2a4830aae3c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 08:47:01 +0100 Subject: [PATCH 204/372] better follow the same conventions everywhere --- src/math.f90 | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/math.f90 b/src/math.f90 index cf942ab68..923e2badf 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -99,6 +99,7 @@ module math math_invert33, & math_invSym3333, & math_invert, & + math_invert2, & math_symmetric33, & math_symmetric66, & math_skew33, & @@ -779,6 +780,7 @@ end function math_inv33 ! direct Cramer inversion of matrix A. ! also returns determinant ! returns error if not possible, i.e. if det close to zero +! ToDo: has wrong order of arguments (out should be first) !-------------------------------------------------------------------------------------------------- pure subroutine math_invert33(A, InvA, DetA, error) use prec, only: & @@ -847,8 +849,37 @@ function math_invSym3333(A) end function math_invSym3333 +!-------------------------------------------------------------------------------------------------- +!> @brief invert quare matrix of arbitrary dimension +!-------------------------------------------------------------------------------------------------- +subroutine math_invert2(InvA, error, A) + + implicit none + real(pReal), dimension(:,:), intent(in) :: A + + real(pReal), dimension(size(A,1),size(A,2)), intent(out) :: invA + logical, intent(out) :: error + + integer(pInt) :: ierr + integer(pInt), dimension(size(A,1)) :: ipiv + real(pReal), dimension(size(A,1)) :: work + + external :: & + dgetrf, & + dgetri + + invA = A + call dgetrf(size(A,1),size(A,2),invA,size(A,1),ipiv,ierr) + call dgetri(size(A,1),InvA,size(A,1),ipiv,work,size(A,1),ierr) + error = merge(.true.,.false., ierr /= 0_pInt) + +end subroutine math_invert2 + + !-------------------------------------------------------------------------------------------------- !> @brief invert matrix of arbitrary dimension +! Obsolete: has wrong order of arguments and superflouous argumen myDim +! use math_inver2 instead !-------------------------------------------------------------------------------------------------- subroutine math_invert(myDim,A, InvA, error) @@ -1926,6 +1957,7 @@ end function math_symmetricEulers !-------------------------------------------------------------------------------------------------- !> @brief eigenvalues and eigenvectors of symmetric matrix m +! ToDo: has wrong order of arguments !-------------------------------------------------------------------------------------------------- subroutine math_eigenValuesVectorsSym(m,values,vectors,error) @@ -1952,6 +1984,7 @@ end subroutine math_eigenValuesVectorsSym !> @author Joachim Kopp, Max–Planck–Institut für Kernphysik, Heidelberg (Copyright (C) 2006) !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @details See http://arxiv.org/abs/physics/0610206 (DSYEVH3) +! ToDo: has wrong order of arguments !-------------------------------------------------------------------------------------------------- subroutine math_eigenValuesVectorsSym33(m,values,vectors) From 11bb6f1f47748b7bc396205d0b0ff05097260a26 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 09:14:23 +0100 Subject: [PATCH 205/372] limit size to actual Ngrains, not potential maximum --- src/homogenization.f90 | 43 ++++-------- src/homogenization_RGC.f90 | 115 +++++++++++++++---------------- src/homogenization_isostrain.f90 | 30 +++----- 3 files changed, 78 insertions(+), 110 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 3f62ffd7d..aadc7ee89 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -743,10 +743,8 @@ subroutine homogenization_partitionDeformation(ip,el) use mesh, only: & mesh_element use material, only: & - mappingHomogenization, & homogenization_type, & - homogenization_maxNgrains, & - homogenization_typeInstance, & + homogenization_Ngrains, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & HOMOGENIZATION_RGC_ID @@ -761,28 +759,20 @@ subroutine homogenization_partitionDeformation(ip,el) integer(pInt), intent(in) :: & ip, & !< integration point el !< element number - integer(pInt) :: & - instance, of chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) case (HOMOGENIZATION_NONE_ID) chosenHomogenization - crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el) = 0.0_pReal - crystallite_partionedF(1:3,1:3,1:1,ip,el) = & - spread(materialpoint_subF(1:3,1:3,ip,el),3,1) + crystallite_partionedF(1:3,1:3,1,ip,el) = materialpoint_subF(1:3,1:3,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_isostrain_partitionDeformation(& - crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & - materialpoint_subF(1:3,1:3,ip,el),& - instance) + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + materialpoint_subF(1:3,1:3,ip,el)) case (HOMOGENIZATION_RGC_ID) chosenHomogenization - instance = homogenization_typeInstance(mesh_element(3,el)) - of = mappingHomogenization(1,ip,el) call homogenization_RGC_partitionDeformation(& - crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & materialpoint_subF(1:3,1:3,ip,el),& ip, & el) @@ -869,7 +859,7 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) use material, only: & homogenization_type, & homogenization_typeInstance, & - homogenization_maxNgrains, & + homogenization_Ngrains, & HOMOGENIZATION_NONE_ID, & HOMOGENIZATION_ISOSTRAIN_ID, & HOMOGENIZATION_RGC_ID @@ -884,32 +874,27 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) integer(pInt), intent(in) :: & ip, & !< integration point el !< element number - integer(pInt) :: & - instance chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) case (HOMOGENIZATION_NONE_ID) chosenHomogenization - materialpoint_P(1:3,1:3,ip,el) = sum(crystallite_P(1:3,1:3,1:1,ip,el),3) - materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) & - = sum(crystallite_dPdF(1:3,1:3,1:3,1:3,1:1,ip,el),5) + materialpoint_P(1:3,1:3,ip,el) = crystallite_P(1:3,1:3,1,ip,el) + materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) = crystallite_dPdF(1:3,1:3,1:3,1:3,1,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_isostrain_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& - crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & - instance) + crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + homogenization_typeInstance(mesh_element(3,el))) case (HOMOGENIZATION_RGC_ID) chosenHomogenization - instance = homogenization_typeInstance(mesh_element(3,el)) call homogenization_RGC_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& - crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & - instance) + crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + homogenization_typeInstance(mesh_element(3,el))) end select chosenHomogenization end subroutine homogenization_averageStressAndItsTangent diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 1448b5a76..6c67249d0 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -66,7 +66,8 @@ module homogenization_RGC type(tparameters), dimension(:), allocatable, private :: & param type(tRGCstate), dimension(:), allocatable, private :: & - state + state, & + state0 type(tRGCdependentState), dimension(:), allocatable, private :: & dependentState @@ -100,24 +101,35 @@ subroutine homogenization_RGC_init() pReal, & pInt use debug, only: & - debug_level, & - debug_homogenization, & - debug_levelBasic, & - debug_levelExtensive +#ifdef DEBUG + debug_i, & + debug_e, & +#endif + debug_level, & + debug_homogenization, & + debug_levelBasic use math, only: & math_EulerToR,& INRAD use IO, only: & IO_error, & IO_timeStamp - use material + use material, only: & + homogenization_type, & + material_homog, & + homogState, & + HOMOGENIZATION_RGC_ID, & + HOMOGENIZATION_RGC_LABEL, & + homogenization_typeInstance, & + homogenization_Noutput, & + homogenization_Ngrains use config, only: & config_homogenization implicit none integer(pInt) :: & Ninstance, & - h, i, j, & + h, i, & NofMyHomog, outputSize, & sizeState, nIntFaceTot @@ -143,6 +155,7 @@ subroutine homogenization_RGC_init() allocate(param(Ninstance)) allocate(state(Ninstance)) + allocate(state0(Ninstance)) allocate(dependentState(Ninstance)) allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0_pInt) @@ -153,13 +166,14 @@ subroutine homogenization_RGC_init() if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle associate(prm => param(homogenization_typeInstance(h)), & stt => state(homogenization_typeInstance(h)), & + st0 => state0(homogenization_typeInstance(h)), & dst => dependentState(homogenization_typeInstance(h)), & config => config_homogenization(h)) #ifdef DEBUG - if (h==material_homogenizationAt(debug_e)) then - prm%of_debug = mappingHomogenization(1,debug_i,debug_e) - endif + !if (h==material_homogenizationAt(debug_e)) then + ! prm%of_debug = mappingHomogenization(1,debug_i,debug_e) + !endif #endif prm%Nconstituents = config%getInts('clustersize',requiredShape=[3]) @@ -206,15 +220,6 @@ subroutine homogenization_RGC_init() enddo - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - write(6,'(a15,1x,i4,/)') 'instance: ', homogenization_typeInstance(h) - write(6,'(a25,3(1x,i8))') 'cluster size: ',(prm%Nconstituents(j),j=1_pInt,3_pInt) - write(6,'(a25,1x,e10.3)') 'scaling parameter: ', prm%xiAlpha - write(6,'(a25,1x,e10.3)') 'over-proportionality: ', prm%ciAlpha - write(6,'(a25,3(1x,e10.3))') 'grain size: ',(prm%dAlpha(j),j=1_pInt,3_pInt) - write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(prm%angles(j),j=1_pInt,3_pInt) - endif - NofMyHomog = count(material_homog == h) nIntFaceTot = 3_pInt*( (prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & @@ -229,6 +234,7 @@ subroutine homogenization_RGC_init() allocate(homogState(h)%state (sizeState,NofMyHomog), source=0.0_pReal) stt%relaxationVector => homogState(h)%state(1:nIntFaceTot,:) + st0%relaxationVector => homogState(h)%state0(1:nIntFaceTot,:) stt%work => homogState(h)%state(nIntFaceTot+1,:) stt%penaltyEnergy => homogState(h)%state(nIntFaceTot+2,:) @@ -238,12 +244,9 @@ subroutine homogenization_RGC_init() allocate(dst%mismatch( 3, NofMyHomog)) allocate(dst%orientation( 3,3,NofMyHomog)) - !-------------------------------------------------------------------------------------------------- ! assigning cluster orientations - do j=1, NofMyHomog - dst%orientation(1:3,1:3,j) = math_EulerToR(prm%angles*inRad) !ToDo: use spread - enddo + dst%orientation = spread(math_EulerToR(prm%angles*inRad),3,NofMyHomog) end associate @@ -262,14 +265,12 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) debug_homogenization, & debug_levelExtensive #endif - use material, only: & - homogenization_maxNgrains implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain + real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain - real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F - integer(pInt), intent(in) :: & + real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F + integer(pInt), intent(in) :: & instance, & of @@ -278,10 +279,10 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) integer(pInt), dimension (3) :: iGrain3 integer(pInt) :: iGrain,iFace,i,j -!-------------------------------------------------------------------------------------------------- -! compute the deformation gradient of individual grains due to relaxations associate(prm => param(instance)) +!-------------------------------------------------------------------------------------------------- +! compute the deformation gradient of individual grains due to relaxations F = 0.0_pReal do iGrain = 1_pInt,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) @@ -294,8 +295,6 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! resulting relaxed deformation gradient -!-------------------------------------------------------------------------------------------------- -! debugging the grain deformation gradients #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then write(6,'(1x,a32,1x,i3)')'Deformation gradient of grain: ',iGrain @@ -329,14 +328,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) debug_i #endif use math, only: & - math_invert + math_invert2 use material, only: & material_homogenizationAt, & - homogenization_maxNgrains, & homogenization_typeInstance, & - homogState, & - mappingHomogenization, & - homogenization_Ngrains + mappingHomogenization, & + homogenization_maxNgrains use numerics, only: & absTol_RGC, & relTol_RGC, & @@ -380,11 +377,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) return endif zeroTimeStep - instance = homogenization_typeInstance(material_homogenizationAt(el)) of = mappingHomogenization(1,ip,el) - associate(stt => state(instance), dst => dependentState(instance), prm => param(instance)) + associate(stt => state(instance), st0 => state0(instance), dst => dependentState(instance), prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! get the dimension of the cluster (grains and interfaces) @@ -399,8 +395,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) relax = stt%relaxationVector(:,of) - drelax = relax & - - homogState(mappingHomogenization(2,ip,el))%state0(1:3_pInt*nIntFaceTot,of) + drelax = stt%relaxationVector(:,of) - st0%relaxationVector(:,of) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then @@ -513,7 +508,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - do iGrain = 1_pInt,homogenization_Ngrains(material_homogenizationAt(el)) ! time-integration loop for work and energy + do iGrain = 1_pInt,product(prm%Nconstituents) do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt stt%work(of) = stt%work(of) & + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) @@ -726,7 +721,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix allocate(jnverse(3_pInt*nIntFaceTot,3_pInt*nIntFaceTot),source=0.0_pReal) - call math_invert(size(jmatrix,1),jmatrix,jnverse,error) ! Compute the inverse of the overall Jacobian matrix + call math_invert2(jnverse,error,jmatrix) #ifdef DEBUG if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then @@ -745,8 +740,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do i = 1_pInt,3_pInt*nIntFaceTot;do j = 1_pInt,3_pInt*nIntFaceTot drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable enddo; enddo - relax = relax + drelax ! Updateing the state variable for the next iteration - stt%relaxationVector(:,of) = relax + stt%relaxationVector(:,of) = relax + drelax ! Updateing the state variable for the next iteration if (any(abs(drelax) > maxdRelax_RGC)) then ! Forcing cutback when the incremental change of relaxation vector becomes too large homogenization_RGC_updateState = [.true.,.false.] !$OMP CRITICAL (write2out) @@ -760,7 +754,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then write(6,'(1x,a30)')'Returned state: ' do i = 1_pInt,size(stt%relaxationVector(:,of)) - write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(:,of) + write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' flush(6) @@ -813,7 +807,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) #ifdef DEBUG debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. prm%of_debug = of + .and. prm%of_debug == of if (debugActive) then write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el @@ -969,9 +963,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) do iBase = 1_pInt,3_pInt nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],instance,of) do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal + surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal enddo; enddo - surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) + surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) enddo end function surfaceCorrection @@ -988,8 +982,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension(2) :: equivalentModuli integer(pInt), intent(in) :: & grainID,& - ip, & !< integration point number - el !< element number + ip, & !< integration point number + el !< element number real(pReal), dimension(6,6) :: elasTens real(pReal) :: & cEquiv_11, & @@ -1015,14 +1009,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- !> @brief calculating the grain deformation gradient (the same with - ! homogenization_RGC_partionDeformation, but used only for perturbation scheme) + ! homogenization_RGC_partitionDeformation, but used only for perturbation scheme) !-------------------------------------------------------------------------------------------------- subroutine grainDeformation(F, avgF, instance, of) implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain - real(pReal), dimension (3,3), intent(in) :: avgF !< - integer(pInt), intent(in) :: & + real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain + + real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F + integer(pInt), intent(in) :: & instance, & of @@ -1031,7 +1026,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt), dimension (3) :: iGrain3 integer(pInt) :: iGrain,iFace,i,j - !-------------------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations associate(prm => param(instance)) @@ -1060,14 +1055,13 @@ end function homogenization_RGC_updateState !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) - use material, only: & - homogenization_maxNgrains implicit none real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses - real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses + + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses integer(pInt), intent(in) :: instance avgP = sum(P,3) /real(product(param(instance)%Nconstituents),pReal) @@ -1080,6 +1074,7 @@ end subroutine homogenization_RGC_averageStressAndItsTangent !> @brief return array of homogenization results for post file inclusion !-------------------------------------------------------------------------------------------------- pure function homogenization_RGC_postResults(instance,of) result(postResults) + implicit none integer(pInt), intent(in) :: & instance, & diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 9987b7e61..42c0c9287 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -110,26 +110,16 @@ end subroutine homogenization_isostrain_init !-------------------------------------------------------------------------------------------------- !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_partitionDeformation(F,avgF,instance) +subroutine homogenization_isostrain_partitionDeformation(F,avgF) use prec, only: & pReal - use material, only: & - homogenization_maxNgrains implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partitioned deformation gradient + real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point - integer(pInt), intent(in) :: instance + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point - - associate(prm => param(instance)) - - F(1:3,1:3,1:prm%Nconstituents) = spread(avgF,3,prm%Nconstituents) - if (homogenization_maxNgrains > prm%Nconstituents) & - F(1:3,1:3,prm%Nconstituents+1_pInt:homogenization_maxNgrains) = 0.0_pReal - - end associate + F = spread(avgF,3,size(F,3)) end subroutine homogenization_isostrain_partitionDeformation @@ -140,16 +130,14 @@ end subroutine homogenization_isostrain_partitionDeformation subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) use prec, only: & pReal - use material, only: & - homogenization_maxNgrains implicit none - real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point - real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: P !< partitioned stresses - real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< partitioned stiffnesses - integer(pInt), intent(in) :: instance + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer(pInt), intent(in) :: instance associate(prm => param(instance)) From 57c6271894b29ab0e7fe47ed6433370744c9003d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 09:33:47 +0100 Subject: [PATCH 206/372] using less global variables --- src/homogenization.f90 | 10 +++---- src/homogenization_RGC.f90 | 60 ++++++++++++++++++++------------------ 2 files changed, 36 insertions(+), 34 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index aadc7ee89..6c968f723 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -792,7 +792,7 @@ function homogenization_updateState(ip,el) homogenization_type, & thermal_type, & damage_type, & - homogenization_maxNgrains, & + homogenization_Ngrains, & HOMOGENIZATION_RGC_ID, & THERMAL_adiabatic_ID, & DAMAGE_local_ID @@ -819,12 +819,12 @@ function homogenization_updateState(ip,el) case (HOMOGENIZATION_RGC_ID) chosenHomogenization homogenization_updateState = & homogenization_updateState .and. & - homogenization_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & - crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & - crystallite_partionedF0(1:3,1:3,1:homogenization_maxNgrains,ip,el),& + homogenization_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_partionedF0(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el),& materialpoint_subF(1:3,1:3,ip,el),& materialpoint_subdt(ip,el), & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & ip, & el) end select chosenHomogenization diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 6c67249d0..8a101eb72 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -332,8 +332,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) use material, only: & material_homogenizationAt, & homogenization_typeInstance, & - mappingHomogenization, & - homogenization_maxNgrains + mappingHomogenization use numerics, only: & absTol_RGC, & relTol_RGC, & @@ -347,30 +346,33 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: & + real(pReal), dimension (:,:,:), intent(in) :: & P,& !< array of P F,& !< array of F F0 !< array of initial F - real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffness - real(pReal), dimension (3,3), intent(in) :: avgF !< average F - real(pReal), intent(in) :: dt !< time increment - integer(pInt), intent(in) :: & + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< array of current grain stiffness + real(pReal), dimension (3,3), intent(in) :: avgF !< average F + real(pReal), intent(in) :: dt !< time increment + integer(pInt), intent(in) :: & ip, & !< integration point number el !< element number logical, dimension(2) :: homogenization_RGC_updateState + integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc - integer(pInt), dimension (2) :: residLoc - integer(pInt) instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of - real(pReal), dimension (3,3,homogenization_maxNgrains) :: R,pF,pR,D,pD - real(pReal), dimension (3,homogenization_maxNgrains) :: NN,devNull33 - real(pReal), dimension (3) :: normP,normN,mornP,mornN - real(pReal) :: residMax,stresMax,devNull - logical error - + integer(pInt) :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of + real(pReal), dimension (3,3,size(P,3)) :: R,pF,pR,D,pD + real(pReal), dimension (3,size(P,3)) :: NN,devNull + real(pReal), dimension (3) :: normP,normN,mornP,mornN + real(pReal) :: residMax,stresMax + logical :: error real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax +#ifdef DEBUG + integer(pInt), dimension (3) :: stresLoc + integer(pInt), dimension (2) :: residLoc +#endif zeroTimeStep: if(dEq0(dt)) then homogenization_RGC_updateState = .true. ! pretend everything is fine and return @@ -475,13 +477,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! convergence check for stress residual stresMax = maxval(abs(P)) ! get the maximum of first Piola-Kirchhoff (material) stress - stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress residMax = maxval(abs(tract)) ! get the maximum of the residual - residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & .and. debug_e == el .and. debug_i == ip) then + stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress + residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual write(6,'(1x,a)')' ' write(6,'(1x,a,1x,i2,1x,i4)')'RGC residual check ...',ip,el write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2,i2)')'Max stress: ',stresMax, & @@ -637,8 +639,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector stt%relaxationVector(:,of) = p_relax call grainDeformation(pF,avgF,instance,of) ! rain deformation from perturbed state - call stressPenalty(pR,DevNull33, avgF,pF,ip,el,instance,of) ! stress penalty due to interface mismatch from perturbed state - call volumePenalty(pD,devNull, avgF,pF,nGrain,instance,of) ! stress penalty due to volume discrepancy from perturbed state + call stressPenalty(pR,DevNull, avgF,pF,ip,el,instance,of) ! stress penalty due to interface mismatch from perturbed state + call volumePenalty(pD,devNull(1,1), avgF,pF,nGrain,instance,of) ! stress penalty due to volume discrepancy from perturbed state !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state @@ -774,12 +776,12 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) xSmoo_RGC implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen !< stress-like penalty - real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch + real(pReal), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty + real(pReal), dimension (:,:), intent(out) :: nMis !< total amount of mismatch - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients - real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el,instance,of + real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients + real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor + integer(pInt), intent(in) :: ip,el,instance,of integer(pInt), dimension (4) :: intFace integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim @@ -894,17 +896,17 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) volDiscrPow_RGC implicit none - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen ! stress-like penalty due to volume - real(pReal), intent(out) :: vDiscrep ! total volume discrepancy + real(pReal), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume + real(pReal), intent(out) :: vDiscrep ! total volume discrepancy - real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef ! deformation gradients - real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient + real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients + real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient integer(pInt), intent(in) :: & Ngrain, & instance, & of - real(pReal), dimension (homogenization_maxNgrains) :: gVol + real(pReal), dimension(size(vPen,3)) :: gVol integer(pInt) :: i !-------------------------------------------------------------------------------------------------- From 49ef8e70d6435a1f86bcdc71e0dec2358df651a7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 09:48:47 +0100 Subject: [PATCH 207/372] no need to prefix private functions --- src/homogenization.f90 | 72 ++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 6c968f723..795639b23 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -45,10 +45,10 @@ module homogenization materialpoint_stressAndItsTangent, & materialpoint_postResults private :: & - homogenization_partitionDeformation, & - homogenization_updateState, & - homogenization_averageStressAndItsTangent, & - homogenization_postResults + partitionDeformation, & + updateState, & + averageStressAndItsTangent, & + postResults contains @@ -118,12 +118,9 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! parse homogenization from config file - if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) & - call homogenization_none_init - if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) & - call homogenization_isostrain_init - if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) & - call homogenization_RGC_init + if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) call homogenization_none_init + if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) call homogenization_isostrain_init + if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) call homogenization_RGC_init !-------------------------------------------------------------------------------------------------- ! parse thermal from config file @@ -611,7 +608,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) IpLooping2: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) if ( materialpoint_requested(i,e) .and. & ! process requested but... .not. materialpoint_doneAndHappy(1,i,e)) then ! ...not yet done material points - call homogenization_partitionDeformation(i,e) ! partition deformation onto constituents + call partitionDeformation(i,e) ! partition deformation onto constituents crystallite_dt(1:myNgrains,i,e) = materialpoint_subdt(i,e) ! propagate materialpoint dt to grains crystallite_requested(1:myNgrains,i,e) = .true. ! request calculation for constituents else @@ -638,7 +635,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) materialpoint_doneAndHappy(1:2,i,e) = [.true.,.false.] materialpoint_converged(i,e) = .false. else - materialpoint_doneAndHappy(1:2,i,e) = homogenization_updateState(i,e) + materialpoint_doneAndHappy(1:2,i,e) = updateState(i,e) materialpoint_converged(i,e) = all(materialpoint_doneAndHappy(1:2,i,e)) ! converged if done and happy endif endif @@ -657,7 +654,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) !$OMP PARALLEL DO elementLooping4: do e = FEsolving_execElem(1),FEsolving_execElem(2) IpLooping4: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - call homogenization_averageStressAndItsTangent(i,e) + call averageStressAndItsTangent(i,e) enddo IpLooping4 enddo elementLooping4 !$OMP END PARALLEL DO @@ -715,7 +712,7 @@ subroutine materialpoint_postResults thePos = thePos + 1_pInt if (theSize > 0_pInt) then ! any homogenization results to mention? - materialpoint_results(thePos+1:thePos+theSize,i,e) = homogenization_postResults(i,e) ! tell homogenization results + materialpoint_results(thePos+1:thePos+theSize,i,e) = postResults(i,e) ! tell homogenization results thePos = thePos + theSize endif @@ -739,7 +736,7 @@ end subroutine materialpoint_postResults !-------------------------------------------------------------------------------------------------- !> @brief partition material point def grad onto constituents !-------------------------------------------------------------------------------------------------- -subroutine homogenization_partitionDeformation(ip,el) +subroutine partitionDeformation(ip,el) use mesh, only: & mesh_element use material, only: & @@ -778,14 +775,14 @@ subroutine homogenization_partitionDeformation(ip,el) el) end select chosenHomogenization -end subroutine homogenization_partitionDeformation +end subroutine partitionDeformation !-------------------------------------------------------------------------------------------------- !> @brief update the internal state of the homogenization scheme and tell whether "done" and !> "happy" with result !-------------------------------------------------------------------------------------------------- -function homogenization_updateState(ip,el) +function updateState(ip,el) use mesh, only: & mesh_element use material, only: & @@ -812,13 +809,13 @@ function homogenization_updateState(ip,el) integer(pInt), intent(in) :: & ip, & !< integration point el !< element number - logical, dimension(2) :: homogenization_updateState + logical, dimension(2) :: updateState - homogenization_updateState = .true. + updateState = .true. chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) case (HOMOGENIZATION_RGC_ID) chosenHomogenization - homogenization_updateState = & - homogenization_updateState .and. & + updateState = & + updateState .and. & homogenization_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & crystallite_partionedF0(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el),& @@ -831,8 +828,8 @@ function homogenization_updateState(ip,el) chosenThermal: select case (thermal_type(mesh_element(3,el))) case (THERMAL_adiabatic_ID) chosenThermal - homogenization_updateState = & - homogenization_updateState .and. & + updateState = & + updateState .and. & thermal_adiabatic_updateState(materialpoint_subdt(ip,el), & ip, & el) @@ -840,20 +837,20 @@ function homogenization_updateState(ip,el) chosenDamage: select case (damage_type(mesh_element(3,el))) case (DAMAGE_local_ID) chosenDamage - homogenization_updateState = & - homogenization_updateState .and. & + updateState = & + updateState .and. & damage_local_updateState(materialpoint_subdt(ip,el), & ip, & el) end select chosenDamage -end function homogenization_updateState +end function updateState !-------------------------------------------------------------------------------------------------- !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- -subroutine homogenization_averageStressAndItsTangent(ip,el) +subroutine averageStressAndItsTangent(ip,el) use mesh, only: & mesh_element use material, only: & @@ -897,13 +894,14 @@ subroutine homogenization_averageStressAndItsTangent(ip,el) homogenization_typeInstance(mesh_element(3,el))) end select chosenHomogenization -end subroutine homogenization_averageStressAndItsTangent +end subroutine averageStressAndItsTangent + !-------------------------------------------------------------------------------------------------- !> @brief return array of homogenization results for post file inclusion. call only, !> if homogenization_sizePostResults(i,e) > 0 !! !-------------------------------------------------------------------------------------------------- -function homogenization_postResults(ip,el) +function postResults(ip,el) use mesh, only: & mesh_element use material, only: & @@ -943,13 +941,13 @@ function homogenization_postResults(ip,el) real(pReal), dimension( homogState (mappingHomogenization(2,ip,el))%sizePostResults & + thermalState (mappingHomogenization(2,ip,el))%sizePostResults & + damageState (mappingHomogenization(2,ip,el))%sizePostResults) :: & - homogenization_postResults + postResults integer(pInt) :: & startPos, endPos ,& of, instance - homogenization_postResults = 0.0_pReal + postResults = 0.0_pReal startPos = 1_pInt endPos = homogState(mappingHomogenization(2,ip,el))%sizePostResults chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) @@ -957,7 +955,7 @@ function homogenization_postResults(ip,el) case (HOMOGENIZATION_RGC_ID) chosenHomogenization instance = homogenization_typeInstance(material_homogenizationAt(el)) of = mappingHomogenization(1,ip,el) - homogenization_postResults(startPos:endPos) = homogenization_RGC_postResults(instance,of) + postResults(startPos:endPos) = homogenization_RGC_postResults(instance,of) end select chosenHomogenization @@ -966,9 +964,9 @@ function homogenization_postResults(ip,el) chosenThermal: select case (thermal_type(mesh_element(3,el))) case (THERMAL_adiabatic_ID) chosenThermal - homogenization_postResults(startPos:endPos) = thermal_adiabatic_postResults(ip, el) + postResults(startPos:endPos) = thermal_adiabatic_postResults(ip, el) case (THERMAL_conduction_ID) chosenThermal - homogenization_postResults(startPos:endPos) = thermal_conduction_postResults(ip, el) + postResults(startPos:endPos) = thermal_conduction_postResults(ip, el) end select chosenThermal @@ -977,12 +975,12 @@ function homogenization_postResults(ip,el) chosenDamage: select case (damage_type(mesh_element(3,el))) case (DAMAGE_local_ID) chosenDamage - homogenization_postResults(startPos:endPos) = damage_local_postResults(ip, el) + postResults(startPos:endPos) = damage_local_postResults(ip, el) case (DAMAGE_nonlocal_ID) chosenDamage - homogenization_postResults(startPos:endPos) = damage_nonlocal_postResults(ip, el) + postResults(startPos:endPos) = damage_nonlocal_postResults(ip, el) end select chosenDamage -end function homogenization_postResults +end function postResults end module homogenization From 6b6a26eb18979f5440328fe5d314a3b2d2f72f09 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 09:53:37 +0100 Subject: [PATCH 208/372] less 'use' statements --- src/homogenization_RGC.f90 | 41 ++++++++++++++++---------------------- 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 8a101eb72..1df881df0 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -97,9 +97,6 @@ subroutine homogenization_RGC_init() compiler_version, & compiler_options #endif - use prec, only: & - pReal, & - pInt use debug, only: & #ifdef DEBUG debug_i, & @@ -115,6 +112,10 @@ subroutine homogenization_RGC_init() IO_error, & IO_timeStamp use material, only: & +#ifdef DEBUG + material_homogenizationAt, & + mappingHomogenization, & +#endif homogenization_type, & material_homog, & homogState, & @@ -171,9 +172,9 @@ subroutine homogenization_RGC_init() config => config_homogenization(h)) #ifdef DEBUG - !if (h==material_homogenizationAt(debug_e)) then - ! prm%of_debug = mappingHomogenization(1,debug_i,debug_e) - !endif + if (h==material_homogenizationAt(debug_e)) then + prm%of_debug = mappingHomogenization(1,debug_i,debug_e) + endif #endif prm%Nconstituents = config%getInts('clustersize',requiredShape=[3]) @@ -323,9 +324,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) use debug, only: & debug_level, & debug_homogenization,& - debug_levelExtensive, & - debug_e, & - debug_i + debug_levelExtensive #endif use math, only: & math_invert2 @@ -360,7 +359,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) logical, dimension(2) :: homogenization_RGC_updateState integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID - integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc + integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P integer(pInt) :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of real(pReal), dimension (3,3,size(P,3)) :: R,pF,pR,D,pD real(pReal), dimension (3,size(P,3)) :: NN,devNull @@ -481,7 +480,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then + .and. prm%of_debug == of) then stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual write(6,'(1x,a)')' ' @@ -502,10 +501,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) homogenization_RGC_updateState = .true. #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - write(6,'(1x,a55,/)')'... done and happy' - flush(6) - endif + .and. prm%of_debug == of) write(6,'(1x,a55,/)')'... done and happy' + flush(6) #endif !-------------------------------------------------------------------------------------------------- @@ -525,7 +522,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then + .and. prm%of_debug == of) then write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',stt%work(of) write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',dst%mismatch(1,of), & dst%mismatch(2,of), & @@ -547,10 +544,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - write(6,'(1x,a55,/)')'... broken' - flush(6) - endif + .and. prm%of_debug == of) write(6,'(1x,a,/)') '... broken' + flush(6) #endif return @@ -558,10 +553,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) else ! proceed with computing the Jacobian and state update #ifdef DEBUG if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & - .and. debug_e == el .and. debug_i == ip) then - write(6,'(1x,a55,/)')'... not yet done' - flush(6) - endif + .and. prm%of_debug == of) write(6,'(1x,a,/)') '... not yet done' + flush(6) #endif endif From aaea11d96b5b0a0c8d7e871906a1af21d2ef6a33 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 17:03:49 +0100 Subject: [PATCH 209/372] make similarity of state/param structure clear --- src/plastic_disloUCLA.f90 | 12 ++++++------ src/plastic_isotropic.f90 | 9 +++++---- src/plastic_kinematichardening.f90 | 9 +++++---- src/plastic_phenopowerlaw.f90 | 9 +++++---- 4 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 9d8703277..94e07fc84 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -81,7 +81,7 @@ module plastic_disloUCLA rhoEdge, & rhoEdgeDip, & accshear - end type + end type tDisloUCLAState type, private :: tDisloUCLAdependentState real(pReal), allocatable, dimension(:,:) :: & @@ -90,13 +90,13 @@ module plastic_disloUCLA threshold_stress end type tDisloUCLAdependentState - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - type(tDisloUCLAState ), allocatable, dimension(:), private :: & +!-------------------------------------------------------------------------------------------------- +! containers for parameters and state + type(tParameters), allocatable, dimension(:), private :: param + type(tDisloUCLAState ), allocatable, dimension(:), private :: & dotState, & state - type(tDisloUCLAdependentState), allocatable, dimension(:), private :: & - dependentState + type(tDisloUCLAdependentState), allocatable, dimension(:), private :: dependentState public :: & plastic_disloUCLA_init, & diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 219226ad4..7fa65ff7b 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -48,16 +48,17 @@ module plastic_isotropic outputID logical :: & dilatation - end type + end type tParameters type, private :: tIsotropicState real(pReal), pointer, dimension(:) :: & flowstress, & accumulatedShear - end type + end type tIsotropicState - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) +!-------------------------------------------------------------------------------------------------- +! containers for parameters and state + type(tParameters), allocatable, dimension(:), private :: param type(tIsotropicState), allocatable, dimension(:), private :: & dotState, & state diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index fe7fa5ef1..690349c96 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -58,7 +58,7 @@ module plastic_kinehardening Nslip !< number of active slip systems for each family integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID !< ID of each post result output - end type + end type tParameters type, private :: tKinehardeningState real(pReal), pointer, dimension(:,:) :: & !< vectors along NipcMyInstance @@ -68,10 +68,11 @@ module plastic_kinehardening chi0, & !< backstress at last switch of stress sense gamma0, & !< accumulated shear at last switch of stress sense accshear !< accumulated (absolute) shear - end type + end type tKinehardeningState - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) +!-------------------------------------------------------------------------------------------------- +! containers for parameters and state + type(tParameters), allocatable, dimension(:), private :: param type(tKinehardeningState), allocatable, dimension(:), private :: & dotState, & deltaState, & diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index c745d6f06..786dcaab2 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -72,7 +72,7 @@ module plastic_phenopowerlaw Ntwin !< number of active twin systems for each family integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID !< ID of each post result output - end type !< container type for internal constitutive parameters + end type tParameters type, private :: tPhenopowerlawState real(pReal), pointer, dimension(:,:) :: & @@ -80,10 +80,11 @@ module plastic_phenopowerlaw xi_twin, & gamma_slip, & gamma_twin - end type + end type tPhenopowerlawState - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) +!-------------------------------------------------------------------------------------------------- +! containers for parameters and state + type(tParameters), allocatable, dimension(:), private :: param type(tPhenopowerlawState), allocatable, dimension(:), private :: & dotState, & state From 9058587a2b0a3f9b554affabe2e2e7eabe0a4b8a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 18:13:00 +0100 Subject: [PATCH 210/372] test failed with Intel 18.0.1 don't know what is going on here. 18.0.3 and gfortran work fine. Bug? --- src/homogenization_RGC.f90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 1df881df0..ef81043eb 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -106,7 +106,7 @@ subroutine homogenization_RGC_init() debug_homogenization, & debug_levelBasic use math, only: & - math_EulerToR,& + math_EulerToR, & INRAD use IO, only: & IO_error, & @@ -180,9 +180,11 @@ subroutine homogenization_RGC_init() prm%Nconstituents = config%getInts('clustersize',requiredShape=[3]) if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') + prm%xiAlpha = config%getFloat('scalingparameter') prm%ciAlpha = config%getFloat('overproportionality') - prm%dAlpha = config%getFloats('grainsize',requiredShape=[3]) + + prm%dAlpha = config%getFloats('grainsize', requiredShape=[3]) prm%angles = config%getFloats('clusterorientation',requiredShape=[3]) outputs = config%getStrings('(output)',defaultVal=emptyStringArray) @@ -239,15 +241,15 @@ subroutine homogenization_RGC_init() stt%work => homogState(h)%state(nIntFaceTot+1,:) stt%penaltyEnergy => homogState(h)%state(nIntFaceTot+2,:) - allocate(dst%volumeDiscrepancy( NofMyHomog)) - allocate(dst%relaxationRate_avg( NofMyHomog)) - allocate(dst%relaxationRate_max( NofMyHomog)) - allocate(dst%mismatch( 3, NofMyHomog)) - allocate(dst%orientation( 3,3,NofMyHomog)) + allocate(dst%volumeDiscrepancy( NofMyHomog)) + allocate(dst%relaxationRate_avg( NofMyHomog)) + allocate(dst%relaxationRate_max( NofMyHomog)) + allocate(dst%mismatch( 3,NofMyHomog)) !-------------------------------------------------------------------------------------------------- ! assigning cluster orientations - dst%orientation = spread(math_EulerToR(prm%angles*inRad),3,NofMyHomog) + dependentState(homogenization_typeInstance(h))%orientation = spread(math_EulerToR(prm%angles*inRad),3,NofMyHomog) + !dst%orientation = spread(math_EulerToR(prm%angles*inRad),3,NofMyHomog) ifort version 18.0.1 crashes (for whatever reason) end associate From 619baefe198d962460c35fb05e014e7629b63fdd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 13 Jan 2019 18:54:20 +0100 Subject: [PATCH 211/372] some comments calling a conversion "Mandel" that does not follow the Mandel convention (at least according to wikipedia) is not really intuitive --- src/DAMASK_abaqus.f | 8 ++++---- src/math.f90 | 13 ++++++++++--- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/DAMASK_abaqus.f b/src/DAMASK_abaqus.f index 69f6fba4b..6c6434e4a 100644 --- a/src/DAMASK_abaqus.f +++ b/src/DAMASK_abaqus.f @@ -322,8 +322,8 @@ subroutine UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,& statev = materialpoint_results(1:min(nstatv,materialpoint_sizeResults),npt,mesh_FEasCP('elem', noel)) - if ( terminallyIll ) pnewdt = 0.5_pReal ! force cutback directly ? -!$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value + if (terminallyIll) pnewdt = 0.5_pReal ! force cutback directly ? +!$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value end subroutine UMAT @@ -331,12 +331,12 @@ end subroutine UMAT !-------------------------------------------------------------------------------------------------- !> @brief calls the exit function of Abaqus/Standard !-------------------------------------------------------------------------------------------------- -subroutine quit(mpie_error) +subroutine quit(DAMASK_error) use prec, only: & pInt implicit none - integer(pInt) :: mpie_error + integer(pInt) :: DAMASK_error flush(6) call xit diff --git a/src/math.f90 b/src/math.f90 index cf942ab68..9b81aaa4b 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -24,6 +24,14 @@ module math 0.0_pReal,0.0_pReal,1.0_pReal & ],[3,3]) !< 3x3 Identity +! ToDo MD: Our naming scheme is a little bit odd: We use essentially the re-ordering according to Nye +! (convenient because Abaqus and Marc want to have 12 on position 4) +! but weight the shear components according to Mandel (convenient for matrix multiplications) +! I suggest to keep Voigt3333to66 (required for reading in elasticity matrices) but rename +! mapMandel to mapNye, math_MandelXtoY to math_XtoY and math_PlainXtoY to math_XtoY. +! It is then clear that math_33to9 just reorders and math_33to6 does the "DAMASK conversion" +! without leaving the impression that it follows any established convention + integer(pInt), dimension (2,6), parameter, private :: & mapMandel = reshape([& 1_pInt,1_pInt, & @@ -32,7 +40,7 @@ module math 1_pInt,2_pInt, & 2_pInt,3_pInt, & 1_pInt,3_pInt & - ],[2,6]) !< arrangement in Mandel notation + ],[2,6]) !< arrangement in Mandel notation. Differs from https://en.wikipedia.org/wiki/Voigt_notation#Mandel_notation real(pReal), dimension(6), parameter, private :: & nrmMandel = [& @@ -870,7 +878,7 @@ subroutine math_invert(myDim,A, InvA, error) invA = A call dgetrf(myDim,myDim,invA,myDim,ipiv,ierr) call dgetri(myDim,InvA,myDim,ipiv,work,myDim,ierr) - error = merge(.true.,.false., ierr /= 0_pInt) ! http://fortraninacworld.blogspot.de/2012/12/ternary-operator.html + error = merge(.true.,.false., ierr /= 0_pInt) end subroutine math_invert @@ -1163,7 +1171,6 @@ end function math_Plain66toMandel66 pure function math_Mandel3333to66(m3333) implicit none - real(pReal), dimension(3,3,3,3), intent(in) :: m3333 real(pReal), dimension(6,6) :: math_Mandel3333to66 integer(pInt) :: i,j From a17bf591cfcee8f6342f054ab7dbf94a65fc3ea8 Mon Sep 17 00:00:00 2001 From: Test User Date: Sun, 13 Jan 2019 21:18:41 +0100 Subject: [PATCH 212/372] [skip ci] updated version information after successful test of v2.0.2-1397-gaaea11d9 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 895c5d6b5..6deded9dc 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1395-g4848e600 +v2.0.2-1397-gaaea11d9 From 8576d72eceda6a5dc811030ed64660aeae41f960 Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 14 Jan 2019 04:57:43 +0100 Subject: [PATCH 213/372] [skip ci] updated version information after successful test of v2.0.2-1398-g619baefe --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 895c5d6b5..8f6e3285d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1395-g4848e600 +v2.0.2-1398-g619baefe From 01a2fffd3cf631db8e00efdd1f9bf07bd522d6a9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 07:27:18 +0100 Subject: [PATCH 214/372] clearer naming for vector <-> tensor conversion and a bunch of other improvements --- src/math.f90 | 452 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 266 insertions(+), 186 deletions(-) diff --git a/src/math.f90 b/src/math.f90 index 9b81aaa4b..9a47631ff 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -24,24 +24,6 @@ module math 0.0_pReal,0.0_pReal,1.0_pReal & ],[3,3]) !< 3x3 Identity -! ToDo MD: Our naming scheme is a little bit odd: We use essentially the re-ordering according to Nye -! (convenient because Abaqus and Marc want to have 12 on position 4) -! but weight the shear components according to Mandel (convenient for matrix multiplications) -! I suggest to keep Voigt3333to66 (required for reading in elasticity matrices) but rename -! mapMandel to mapNye, math_MandelXtoY to math_XtoY and math_PlainXtoY to math_XtoY. -! It is then clear that math_33to9 just reorders and math_33to6 does the "DAMASK conversion" -! without leaving the impression that it follows any established convention - - integer(pInt), dimension (2,6), parameter, private :: & - mapMandel = reshape([& - 1_pInt,1_pInt, & - 2_pInt,2_pInt, & - 3_pInt,3_pInt, & - 1_pInt,2_pInt, & - 2_pInt,3_pInt, & - 1_pInt,3_pInt & - ],[2,6]) !< arrangement in Mandel notation. Differs from https://en.wikipedia.org/wiki/Voigt_notation#Mandel_notation - real(pReal), dimension(6), parameter, private :: & nrmMandel = [& 1.0_pReal, 1.0_pReal, 1.0_pReal, & @@ -52,6 +34,16 @@ module math 1.0_pReal, 1.0_pReal, 1.0_pReal, & 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal) ] !< weighting for Mandel notation (backward) + integer(pInt), dimension (2,6), parameter, private :: & + mapNye = reshape([& + 1_pInt,1_pInt, & + 2_pInt,2_pInt, & + 3_pInt,3_pInt, & + 1_pInt,2_pInt, & + 2_pInt,3_pInt, & + 1_pInt,3_pInt & + ],[2,6]) !< arrangement in Nye notation. + integer(pInt), dimension (2,6), parameter, private :: & mapVoigt = reshape([& 1_pInt,1_pInt, & @@ -62,10 +54,6 @@ module math 1_pInt,2_pInt & ],[2,6]) !< arrangement in Voigt notation - real(pReal), dimension(6), parameter, private :: & - nrmVoigt = 1.0_pReal, & !< weighting for Voigt notation (forward) - invnrmVoigt = 1.0_pReal !< weighting for Voigt notation (backward) - integer(pInt), dimension (2,9), parameter, private :: & mapPlain = reshape([& 1_pInt,1_pInt, & @@ -78,6 +66,56 @@ module math 3_pInt,2_pInt, & 3_pInt,3_pInt & ],[2,9]) !< arrangement in Plain notation + +!-------------------------------------------------------------------------------------------------- +! Provide deprecated names for compatibility + +! ToDo MD: Our naming scheme was a little bit odd: We use essentially the re-ordering according to Nye +! (convenient because Abaqus and Marc want to have 12 on position 4) +! but weight the shear components according to Mandel (convenient for matrix multiplications) + + interface math_Plain33to9 + module procedure math_33to9 + end interface math_Plain33to9 + + interface math_Plain9to33 + module procedure math_9to33 + end interface math_Plain9to33 + + interface math_Mandel33to6 + module procedure math_33to6 + end interface math_Mandel33to6 + + interface math_Mandel6to33 + module procedure math_6to33 + end interface math_Mandel6to33 + + interface math_Plain3333to99 + module procedure math_3333to99 + end interface math_Plain3333to99 + + interface math_Plain99to3333 + module procedure math_99to3333 + end interface math_Plain99to3333 + + interface math_Mandel3333to66 + module procedure math_3333to66 + end interface math_Mandel3333to66 + + interface math_Mandel66to3333 + module procedure math_66to3333 + end interface math_Mandel66to3333 + + public :: & + math_Plain33to9, & + math_Plain9to33, & + math_Mandel33to6, & + math_Mandel6to33, & + math_Plain3333to99, & + math_Plain99to3333, & + math_Mandel3333to66, & + math_Mandel66to3333 +!--------------------------------------------------------------------------------------------------- public :: & math_init, & @@ -116,16 +154,14 @@ module math math_equivStress33, & math_trace33, & math_det33, & - math_Plain33to9, & - math_Plain9to33, & - math_Mandel33to6, & - math_Mandel6to33, & - math_Plain3333to99, & - math_Plain99to3333, & - math_Mandel66toPlain66, & - math_Plain66toMandel66, & - math_Mandel3333to66, & - math_Mandel66to3333, & + math_33to9, & + math_9to33, & + math_33to6, & + math_6to33, & + math_3333to99, & + math_99to3333, & + math_3333to66, & + math_66to3333, & math_Voigt66to3333, & math_qRand, & math_qMul, & @@ -437,9 +473,13 @@ pure function math_identity4th(dimen) integer(pInt), intent(in) :: dimen !< tensor dimension integer(pInt) :: i,j,k,l real(pReal), dimension(dimen,dimen,dimen,dimen) :: math_identity4th + real(pReal), dimension(dimen,dimen) :: identity2nd - forall (i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) math_identity4th(i,j,k,l) = & - 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) + identity2nd = math_identity2nd(dimen) + do concurrent(i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) + math_identity4th(i,j,k,l) & + = 0.5_pReal*(identity2nd(i,k)*identity2nd(j,l)+identity2nd(i,l)*identity2nd(j,k)) + enddo end function math_identity4th @@ -564,7 +604,9 @@ real(pReal) pure function math_mul33xx33(A,B) integer(pInt) :: i,j real(pReal), dimension(3,3) :: C - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) C(i,j) = A(i,j) * B(i,j) + do concurrent(i=1_pInt:3_pInt,j=1_pInt:3_pInt) + C(i,j) = A(i,j) * B(i,j) + enddo math_mul33xx33 = sum(C) end function math_mul33xx33 @@ -581,9 +623,10 @@ pure function math_mul3333xx33(A,B) real(pReal), dimension(3,3), intent(in) :: B integer(pInt) :: i,j - forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt) & + do concurrent(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt) math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3)) - + enddo + end function math_mul3333xx33 @@ -598,8 +641,9 @@ pure function math_mul3333xx3333(A,B) real(pReal), dimension(3,3,3,3), intent(in) :: B real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333 - forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt, k = 1_pInt:3_pInt, l= 1_pInt:3_pInt) & + do concurrent(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt, k = 1_pInt:3_pInt, l= 1_pInt:3_pInt) math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l)) + enddo end function math_mul3333xx3333 @@ -614,8 +658,9 @@ pure function math_mul33x33(A,B) real(pReal), dimension(3,3), intent(in) :: A,B integer(pInt) :: i,j - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + do concurrent(i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_mul33x33(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + enddo end function math_mul33x33 @@ -630,9 +675,10 @@ pure function math_mul66x66(A,B) real(pReal), dimension(6,6), intent(in) :: A,B integer(pInt) :: i,j - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_mul66x66(i,j) = & - A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & - A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + do concurrent(i=1_pInt:6_pInt,j=1_pInt:6_pInt) + math_mul66x66(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) & + + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + enddo end function math_mul66x66 @@ -647,10 +693,11 @@ pure function math_mul99x99(A,B) real(pReal), dimension(9,9), intent(in) :: A,B integer(pInt) i,j - forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_mul99x99(i,j) = & - A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & - A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + & - A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) + do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + math_mul99x99(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) & + + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) & + + A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) + enddo end function math_mul99x99 @@ -747,8 +794,8 @@ end function math_transpose33 !-------------------------------------------------------------------------------------------------- !> @brief Cramer inversion of 33 matrix (function) -! direct Cramer inversion of matrix A. -! returns all zeroes if not possible, i.e. if det close to zero +!> @details Direct Cramer inversion of matrix A. Returns all zeroes if not possible, i.e. +! if determinant is close to zero !-------------------------------------------------------------------------------------------------- pure function math_inv33(A) use prec, only: & @@ -784,9 +831,9 @@ end function math_inv33 !-------------------------------------------------------------------------------------------------- !> @brief Cramer inversion of 33 matrix (subroutine) -! direct Cramer inversion of matrix A. -! also returns determinant -! returns error if not possible, i.e. if det close to zero +!> @details Direct Cramer inversion of matrix A. Also returns determinant +! Returns an error if not possible, i.e. if determinant is close to zero +! ToDo: Output arguments should be first !-------------------------------------------------------------------------------------------------- pure subroutine math_invert33(A, InvA, DetA, error) use prec, only: & @@ -843,20 +890,38 @@ function math_invSym3333(A) dgetrf, & dgetri - temp66_real = math_Mandel3333to66(A) + temp66_real = math_3333to66(A) call dgetrf(6,6,temp66_real,6,ipiv6,ierr) call dgetri(6,temp66_real,6,ipiv6,work6,6,ierr) if (ierr == 0_pInt) then - math_invSym3333 = math_Mandel66to3333(temp66_real) + math_invSym3333 = math_66to3333(temp66_real) else call IO_error(400_pInt, ext_msg = 'math_invSym3333') endif end function math_invSym3333 +!-------------------------------------------------------------------------------------------------- +!> @brief invert quadratic matrix of arbitrary dimension +! ToDo: replaces math_invert +!-------------------------------------------------------------------------------------------------- +subroutine math_invert2(InvA, error, A) + + implicit none + real(pReal), dimension(:,:), intent(in) :: A + + real(pReal), dimension(size(A,1),size(A,1)), intent(out) :: invA + logical, intent(out) :: error + + call math_invert(size(A,1), A, InvA, error) + +end subroutine math_invert2 + !-------------------------------------------------------------------------------------------------- !> @brief invert matrix of arbitrary dimension +! ToDo: Wrong order of arguments and superfluous myDim argument. +! Use math_invert2 instead !-------------------------------------------------------------------------------------------------- subroutine math_invert(myDim,A, InvA, error) @@ -961,15 +1026,14 @@ pure function math_equivStrain33(m) real(pReal), dimension(3,3), intent(in) :: m real(pReal), dimension(3) :: e,s real(pReal) :: math_equivStrain33 - real(pReal), parameter :: TWOTHIRD = 2.0_pReal/3.0_pReal e = [2.0_pReal*m(1,1)-m(2,2)-m(3,3), & 2.0_pReal*m(2,2)-m(3,3)-m(1,1), & 2.0_pReal*m(3,3)-m(1,1)-m(2,2)]/3.0_pReal s = [m(1,2),m(2,3),m(1,3)]*2.0_pReal - math_equivStrain33 = TWOTHIRD*(1.50_pReal*(sum(e**2.0_pReal)) + & - 0.75_pReal*(sum(s**2.0_pReal)))**(0.5_pReal) + math_equivStrain33 = 2.0_pReal/3.0_pReal & + * (1.50_pReal*(sum(e**2.0_pReal))+ 0.75_pReal*(sum(s**2.0_pReal)))**(0.5_pReal) end function math_equivStrain33 @@ -1041,168 +1105,187 @@ end function math_detSym33 !-------------------------------------------------------------------------------------------------- !> @brief convert 33 matrix into vector 9 !-------------------------------------------------------------------------------------------------- -pure function math_Plain33to9(m33) +pure function math_33to9(m33) implicit none - real(pReal), dimension(9) :: math_Plain33to9 - real(pReal), dimension(3,3), intent(in) :: m33 - integer(pInt) :: i - - forall (i=1_pInt:9_pInt) math_Plain33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) - -end function math_Plain33to9 - - -!-------------------------------------------------------------------------------------------------- -!> @brief convert Plain 9 back to 33 matrix -!-------------------------------------------------------------------------------------------------- -pure function math_Plain9to33(v9) - - implicit none - real(pReal), dimension(3,3) :: math_Plain9to33 - real(pReal), dimension(9), intent(in) :: v9 - integer(pInt) :: i - - forall (i=1_pInt:9_pInt) math_Plain9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) - -end function math_Plain9to33 - - -!-------------------------------------------------------------------------------------------------- -!> @brief convert symmetric 33 matrix into Mandel vector 6 -!-------------------------------------------------------------------------------------------------- -pure function math_Mandel33to6(m33) - - implicit none - real(pReal), dimension(6) :: math_Mandel33to6 + real(pReal), dimension(9) :: math_33to9 real(pReal), dimension(3,3), intent(in) :: m33 integer(pInt) :: i - forall (i=1_pInt:6_pInt) math_Mandel33to6(i) = nrmMandel(i)*m33(mapMandel(1,i),mapMandel(2,i)) + forall (i=1_pInt:9_pInt) math_33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) -end function math_Mandel33to6 +end function math_33to9 !-------------------------------------------------------------------------------------------------- -!> @brief convert Mandel 6 back to symmetric 33 matrix +!> @brief convert 9 vector into 33 matrix !-------------------------------------------------------------------------------------------------- -pure function math_Mandel6to33(v6) +pure function math_9to33(v9) implicit none - real(pReal), dimension(6), intent(in) :: v6 - real(pReal), dimension(3,3) :: math_Mandel6to33 + real(pReal), dimension(3,3) :: math_9to33 + real(pReal), dimension(9), intent(in) :: v9 + integer(pInt) :: i - forall (i=1_pInt:6_pInt) - math_Mandel6to33(mapMandel(1,i),mapMandel(2,i)) = invnrmMandel(i)*v6(i) - math_Mandel6to33(mapMandel(2,i),mapMandel(1,i)) = invnrmMandel(i)*v6(i) - end forall + forall (i=1_pInt:9_pInt) math_9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) -end function math_Mandel6to33 +end function math_9to33 !-------------------------------------------------------------------------------------------------- -!> @brief convert 3333 tensor into plain matrix 99 +!> @brief convert symmetric 33 matrix into 6 vector +!> @details Weighted conversion (default) rearranges according to Nye and weights shear +! components according to Mandel. Advisable for matrix operations. +! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_Plain3333to99(m3333) +pure function math_33to6(m33,weighted) implicit none + real(pReal), dimension(6) :: math_33to6 + real(pReal), dimension(3,3), intent(in) :: m33 + logical, optional, intent(in) :: weighted + + real(pReal), dimension(6) :: w + integer(pInt) :: i + + if(present(weighted)) then + w = merge(nrmMandel,1.0_pReal,weighted) + else + w = nrmMandel + endif + + forall (i=1_pInt:6_pInt) math_33to6(i) = w(i)*m33(mapNye(1,i),mapNye(2,i)) + +end function math_33to6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert 6 vector into symmetric 33 matrix +!> @details Weighted conversion (default) rearranges according to Nye and weights shear +! components according to Mandel. Advisable for matrix operations. +! Unweighted conversion only changes order according to Nye +!-------------------------------------------------------------------------------------------------- +pure function math_6to33(v6,weighted) + + implicit none + real(pReal), dimension(3,3) :: math_6to33 + real(pReal), dimension(6), intent(in) :: v6 + logical, optional, intent(in) :: weighted + + real(pReal), dimension(6) :: w + integer(pInt) :: i + + if(present(weighted)) then + w = merge(invnrmMandel,1.0_pReal,weighted) + else + w = invnrmMandel + endif + + do i=1_pInt,6_pInt + math_6to33(mapNye(1,i),mapNye(2,i)) = w(i)*v6(i) + math_6to33(mapNye(2,i),mapNye(1,i)) = w(i)*v6(i) + enddo + +end function math_6to33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert 3333 matrix into vector 99 +!-------------------------------------------------------------------------------------------------- +pure function math_3333to99(m3333) + + implicit none + real(pReal), dimension(9,9) :: math_3333to99 real(pReal), dimension(3,3,3,3), intent(in) :: m3333 - real(pReal), dimension(9,9) :: math_Plain3333to99 + integer(pInt) :: i,j - forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain3333to99(i,j) = & - m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) + do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + math_3333to99(i,j) = m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) + enddo + +end function math_3333to99 -end function math_Plain3333to99 !-------------------------------------------------------------------------------------------------- -!> @brief plain matrix 99 into 3333 tensor +!> @brief convert 99 vector into 3333 matrix !-------------------------------------------------------------------------------------------------- -pure function math_Plain99to3333(m99) +pure function math_99to3333(m99) implicit none + real(pReal), dimension(3,3,3,3) :: math_99to3333 real(pReal), dimension(9,9), intent(in) :: m99 - real(pReal), dimension(3,3,3,3) :: math_Plain99to3333 + integer(pInt) :: i,j - forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain99to3333(mapPlain(1,i),mapPlain(2,i),& - mapPlain(1,j),mapPlain(2,j)) = m99(i,j) + do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + math_99to3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) = m99(i,j) + enddo -end function math_Plain99to3333 +end function math_99to3333 !-------------------------------------------------------------------------------------------------- -!> @brief convert Mandel matrix 66 into Plain matrix 66 +!> @brief convert symmetric 3333 matrix into 66 vector +!> @details Weighted conversion (default) rearranges according to Nye and weights shear +! components according to Mandel. Advisable for matrix operations. +! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_Mandel66toPlain66(m66) - - implicit none - real(pReal), dimension(6,6), intent(in) :: m66 - real(pReal), dimension(6,6) :: math_Mandel66toPlain66 - integer(pInt) :: i,j - - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) & - math_Mandel66toPlain66(i,j) = invnrmMandel(i) * invnrmMandel(j) * m66(i,j) - -end function math_Mandel66toPlain66 - - -!-------------------------------------------------------------------------------------------------- -!> @brief convert Plain matrix 66 into Mandel matrix 66 -!-------------------------------------------------------------------------------------------------- -pure function math_Plain66toMandel66(m66) - - implicit none - real(pReal), dimension(6,6), intent(in) :: m66 - real(pReal), dimension(6,6) :: math_Plain66toMandel66 - integer(pInt) :: i,j - - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) & - math_Plain66toMandel66(i,j) = nrmMandel(i) * nrmMandel(j) * m66(i,j) - -end function math_Plain66toMandel66 - - -!-------------------------------------------------------------------------------------------------- -!> @brief convert symmetric 3333 tensor into Mandel matrix 66 -!-------------------------------------------------------------------------------------------------- -pure function math_Mandel3333to66(m3333) +pure function math_3333to66(m3333,weighted) implicit none + real(pReal), dimension(6,6) :: math_3333to66 real(pReal), dimension(3,3,3,3), intent(in) :: m3333 - real(pReal), dimension(6,6) :: math_Mandel3333to66 + logical, optional, intent(in) :: weighted + + real(pReal), dimension(6) :: w integer(pInt) :: i,j + + if(present(weighted)) then + w = merge(nrmMandel,1.0_pReal,weighted) + else + w = nrmMandel + endif - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_Mandel3333to66(i,j) = & - nrmMandel(i)*nrmMandel(j)*m3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) + do concurrent(i=1_pInt:6_pInt,j=1_pInt:6_pInt) + math_3333to66(i,j) = w(i)*w(j)*m3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) + enddo -end function math_Mandel3333to66 +end function math_3333to66 !-------------------------------------------------------------------------------------------------- -!> @brief convert Mandel matrix 66 back to symmetric 3333 tensor +!> @brief convert 66 vector into symmetric 3333 matrix +!> @details Weighted conversion (default) rearranges according to Nye and weights shear +! components according to Mandel. Advisable for matrix operations. +! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_Mandel66to3333(m66) +pure function math_66to3333(m66,weighted) implicit none - real(pReal), dimension(3,3,3,3) :: math_Mandel66to3333 - real(pReal), dimension(6,6), intent(in) :: m66 + real(pReal), dimension(3,3,3,3) :: math_66to3333 + real(pReal), dimension(6,6), intent(in) :: m66 + logical, optional, intent(in) :: weighted + + real(pReal), dimension(6) :: w integer(pInt) :: i,j + + if(present(weighted)) then + w = merge(invnrmMandel,1.0_pReal,weighted) + else + w = invnrmMandel + endif - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) - math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) = & - invnrmMandel(i)*invnrmMandel(j)*m66(i,j) - math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(1,j),mapMandel(2,j)) = & - invnrmMandel(i)*invnrmMandel(j)*m66(i,j) - math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(2,j),mapMandel(1,j)) = & - invnrmMandel(i)*invnrmMandel(j)*m66(i,j) - math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(2,j),mapMandel(1,j)) = & - invnrmMandel(i)*invnrmMandel(j)*m66(i,j) - end forall + do i=1_pInt,6_pInt; do j=1_pInt, 6_pInt + math_66to3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) + math_66to3333(mapNye(2,i),mapNye(1,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) + math_66to3333(mapNye(1,i),mapNye(2,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) + math_66to3333(mapNye(2,i),mapNye(1,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) + enddo; enddo -end function math_Mandel66to3333 +end function math_66to3333 !-------------------------------------------------------------------------------------------------- @@ -1215,16 +1298,12 @@ pure function math_Voigt66to3333(m66) real(pReal), dimension(6,6), intent(in) :: m66 integer(pInt) :: i,j - forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) - math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(1,j),mapVoigt(2,j)) = & - invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) - math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(1,j),mapVoigt(2,j)) = & - invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) - math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(2,j),mapVoigt(1,j)) = & - invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) - math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = & - invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) - end forall + do i=1_pInt,6_pInt; do j=1_pInt, 6_pInt + math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(1,j),mapVoigt(2,j)) = m66(i,j) + math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(1,j),mapVoigt(2,j)) = m66(i,j) + math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(2,j),mapVoigt(1,j)) = m66(i,j) + math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = m66(i,j) + enddo; enddo end function math_Voigt66to3333 @@ -1632,8 +1711,9 @@ pure function math_qToR(q) real(pReal), dimension(3,3) :: math_qToR, T,S integer(pInt) :: i, j - forall (i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) & + do concurrent (i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) T(i,j) = q(i+1_pInt) * q(j+1_pInt) + enddo S = reshape( [0.0_pReal, -q(4), q(3), & q(4), 0.0_pReal, -q(2), & @@ -2038,7 +2118,7 @@ end function math_eigenvectorBasisSym !-------------------------------------------------------------------------------------------------- !> @brief eigenvector basis of symmetric 33 matrix m !-------------------------------------------------------------------------------------------------- -function math_eigenvectorBasisSym33(m) +pure function math_eigenvectorBasisSym33(m) implicit none real(pReal), dimension(3,3) :: math_eigenvectorBasisSym33 @@ -2103,7 +2183,7 @@ end function math_eigenvectorBasisSym33 !-------------------------------------------------------------------------------------------------- !> @brief logarithm eigenvector basis of symmetric 33 matrix m !-------------------------------------------------------------------------------------------------- -function math_eigenvectorBasisSym33_log(m) +pure function math_eigenvectorBasisSym33_log(m) implicit none real(pReal), dimension(3,3) :: math_eigenvectorBasisSym33_log @@ -2159,11 +2239,12 @@ function math_eigenvectorBasisSym33_log(m) endif threeSimilarEigenvalues math_eigenvectorBasisSym33_log = log(sqrt(values(1))) * EB(1:3,1:3,1) & - + log(sqrt(values(2))) * EB(1:3,1:3,2) & - + log(sqrt(values(3))) * EB(1:3,1:3,3) + + log(sqrt(values(2))) * EB(1:3,1:3,2) & + + log(sqrt(values(3))) * EB(1:3,1:3,3) end function math_eigenvectorBasisSym33_log + !-------------------------------------------------------------------------------------------------- !> @brief rotational part from polar decomposition of 33 tensor m !-------------------------------------------------------------------------------------------------- @@ -2608,13 +2689,12 @@ pure function math_rotate_forward3333(tensor,rot_tensor) real(pReal), dimension(3,3,3,3), intent(in) :: tensor integer(pInt) :: i,j,k,l,m,n,o,p - math_rotate_forward3333= 0.0_pReal - - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt; do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt - do m = 1_pInt,3_pInt; do n = 1_pInt,3_pInt; do o = 1_pInt,3_pInt; do p = 1_pInt,3_pInt - math_rotate_forward3333(i,j,k,l) = math_rotate_forward3333(i,j,k,l) & - + rot_tensor(i,m) * rot_tensor(j,n) & - * rot_tensor(k,o) * rot_tensor(l,p) * tensor(m,n,o,p) + math_rotate_forward3333 = 0.0_pReal + do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt;do k = 1_pInt,3_pInt;do l = 1_pInt,3_pInt + do m = 1_pInt,3_pInt;do n = 1_pInt,3_pInt;do o = 1_pInt,3_pInt;do p = 1_pInt,3_pInt + math_rotate_forward3333(i,j,k,l) & + = math_rotate_forward3333(i,j,k,l) & + + rot_tensor(i,m) * rot_tensor(j,n) * rot_tensor(k,o) * rot_tensor(l,p) * tensor(m,n,o,p) enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo end function math_rotate_forward3333 From 3f40eeacf91844519a5898a848ae73462f899665 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 07:44:36 +0100 Subject: [PATCH 215/372] disorientation was never use not even for nonlocal, but it slows down calculation a lot --- src/crystallite.f90 | 67 ++++++++------------------------------------- 1 file changed, 12 insertions(+), 55 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 4082749b2..50757cb29 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -65,8 +65,7 @@ module crystallite 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 - crystallite_disorientation !< disorientation between two neighboring ips (only calculated for single grain IPs) + 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) crystallite_dPdF0, & !< individual dPdF per grain at start of FE inc @@ -244,8 +243,6 @@ subroutine crystallite_init allocate(crystallite_orientation(4,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_orientation0(4,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_rotation(4,cMax,iMax,eMax), source=0.0_pReal) - if (any(plasticState%nonLocal)) & - allocate(crystallite_disorientation(4,nMax,cMax,iMax,eMax),source=0.0_pReal) allocate(crystallite_localPlasticity(cMax,iMax,eMax), source=.true.) allocate(crystallite_requested(cMax,iMax,eMax), source=.false.) allocate(crystallite_todo(cMax,iMax,eMax), source=.false.) @@ -3534,29 +3531,23 @@ end function integrateStress !-------------------------------------------------------------------------------------------------- -!> @brief calculates orientations and disorientations (in case of single grain ips) +!> @brief calculates orientations !-------------------------------------------------------------------------------------------------- subroutine crystallite_orientations use math, only: & math_rotationalPart33, & - math_RtoQ, & - math_qConj + math_RtoQ use FEsolving, only: & FEsolving_execElem, & FEsolving_execIP use material, only: & + plasticState, & material_phase, & - homogenization_Ngrains, & - plasticState + homogenization_Ngrains use mesh, only: & - mesh_element, & - mesh_ipNeighborhood, & - FE_NipNeighbors, & - FE_geomtype, & - FE_celltype + mesh_element use lattice, only: & - lattice_qDisorientation, & - lattice_structure + lattice_qDisorientation use plastic_nonlocal, only: & plastic_nonlocal_updateCompatibility @@ -3565,27 +3556,20 @@ subroutine crystallite_orientations c, & !< counter in integration point component loop i, & !< counter in integration point loop e, & !< counter in element loop - n, & !< counter in neighbor loop - neighboring_e, & !< neighbor element - neighboring_i, & !< neighbor integration point - myPhase, & ! phase - neighboringPhase - real(pReal), dimension(4) :: & - orientation + myPhase ! phase ! --- CALCULATE ORIENTATION AND LATTICE ROTATION --- -!$OMP PARALLEL DO PRIVATE(orientation) +!$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)) ! somehow this subroutine is not threadsafe, so need critical statement here; not clear, what exactly the problem is !$OMP CRITICAL (polarDecomp) - orientation = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) + crystallite_orientation(1:4,c,i,e) = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) !$OMP END CRITICAL (polarDecomp) crystallite_rotation(1:4,c,i,e) = lattice_qDisorientation(crystallite_orientation0(1:4,c,i,e), &! active rotation from initial - orientation) ! to current orientation (with no symmetry) - crystallite_orientation(1:4,c,i,e) = orientation + crystallite_orientation(1:4,c,i,e)) ! to current orientation (with no symmetry) enddo; enddo; enddo !$OMP END PARALLEL DO @@ -3594,40 +3578,13 @@ subroutine crystallite_orientations ! --- we use crystallite_orientation from above, so need a separate loop nonlocalPresent: if (any(plasticState%nonLocal)) then -!$OMP PARALLEL DO PRIVATE(myPhase,neighboring_e,neighboring_i,neighboringPhase) +!$OMP PARALLEL DO PRIVATE(myPhase) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) myPhase = material_phase(1,i,e) ! get my phase (non-local models make no sense with more than one grain per material point) if (plasticState(myPhase)%nonLocal) then ! if nonlocal model - ! --- calculate disorientation between me and my neighbor --- - - do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) ! loop through my neighbors - neighboring_e = mesh_ipNeighborhood(1,n,i,e) - neighboring_i = mesh_ipNeighborhood(2,n,i,e) - if (neighboring_e > 0 .and. neighboring_i > 0) then ! if neighbor exists - neighboringPhase = material_phase(1,neighboring_i,neighboring_e) ! get my neighbor's phase - if (plasticState(neighboringPhase)%nonLocal) then ! neighbor got also nonlocal plasticity - if (lattice_structure(myPhase) == lattice_structure(neighboringPhase)) then ! if my neighbor has same crystal structure like me - crystallite_disorientation(:,n,1,i,e) = & - lattice_qDisorientation( crystallite_orientation(1:4,1,i,e), & - crystallite_orientation(1:4,1,neighboring_i,neighboring_e), & - lattice_structure(myPhase)) ! calculate disorientation for given symmetry - else ! for neighbor with different phase - crystallite_disorientation(:,n,1,i,e) = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal]! 180 degree rotation about 100 axis - endif - else ! for neighbor with local plasticity - crystallite_disorientation(:,n,1,i,e) = [-1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal]! homomorphic identity - endif - else ! no existing neighbor - crystallite_disorientation(:,n,1,i,e) = [-1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] ! homomorphic identity - endif - enddo - - ! --- calculate compatibility and transmissivity between me and my neighbor --- - call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) - endif enddo; enddo !$OMP END PARALLEL DO From f82a422e218a79c7631f188d87be8058a40057ea Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 09:34:14 +0100 Subject: [PATCH 216/372] do concurrent causes problems on matesting/Intel 18.0.1 --- src/math.f90 | 57 ++++++++++++++++++---------------------------------- 1 file changed, 20 insertions(+), 37 deletions(-) diff --git a/src/math.f90 b/src/math.f90 index 9a47631ff..3d60eba0c 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -459,7 +459,7 @@ pure function math_identity2nd(dimen) real(pReal), dimension(dimen,dimen) :: math_identity2nd math_identity2nd = 0.0_pReal - forall (i=1_pInt:dimen) math_identity2nd(i,i) = 1.0_pReal + forall(i=1_pInt:dimen) math_identity2nd(i,i) = 1.0_pReal end function math_identity2nd @@ -476,10 +476,8 @@ pure function math_identity4th(dimen) real(pReal), dimension(dimen,dimen) :: identity2nd identity2nd = math_identity2nd(dimen) - do concurrent(i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) - math_identity4th(i,j,k,l) & - = 0.5_pReal*(identity2nd(i,k)*identity2nd(j,l)+identity2nd(i,l)*identity2nd(j,k)) - enddo + forall(i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) & + math_identity4th(i,j,k,l) = 0.5_pReal*(identity2nd(i,k)*identity2nd(j,l)+identity2nd(i,l)*identity2nd(j,k)) end function math_identity4th @@ -548,7 +546,7 @@ pure function math_tensorproduct(A,B) real(pReal), dimension(size(A,1),size(B,1)) :: math_tensorproduct integer(pInt) :: i,j - forall (i=1_pInt:size(A,1),j=1_pInt:size(B,1)) math_tensorproduct(i,j) = A(i)*B(j) + forall(i=1_pInt:size(A,1),j=1_pInt:size(B,1)) math_tensorproduct(i,j) = A(i)*B(j) end function math_tensorproduct @@ -563,7 +561,7 @@ pure function math_tensorproduct33(A,B) real(pReal), dimension(3), intent(in) :: A,B integer(pInt) :: i,j - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_tensorproduct33(i,j) = A(i)*B(j) + forall(i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_tensorproduct33(i,j) = A(i)*B(j) end function math_tensorproduct33 @@ -604,9 +602,7 @@ real(pReal) pure function math_mul33xx33(A,B) integer(pInt) :: i,j real(pReal), dimension(3,3) :: C - do concurrent(i=1_pInt:3_pInt,j=1_pInt:3_pInt) - C(i,j) = A(i,j) * B(i,j) - enddo + forall(i=1_pInt:3_pInt,j=1_pInt:3_pInt) C(i,j) = A(i,j) * B(i,j) math_mul33xx33 = sum(C) end function math_mul33xx33 @@ -623,9 +619,7 @@ pure function math_mul3333xx33(A,B) real(pReal), dimension(3,3), intent(in) :: B integer(pInt) :: i,j - do concurrent(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt) - math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3)) - enddo + forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt) math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3)) end function math_mul3333xx33 @@ -641,9 +635,8 @@ pure function math_mul3333xx3333(A,B) real(pReal), dimension(3,3,3,3), intent(in) :: B real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333 - do concurrent(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt, k = 1_pInt:3_pInt, l= 1_pInt:3_pInt) + forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt, k = 1_pInt:3_pInt, l= 1_pInt:3_pInt) & math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l)) - enddo end function math_mul3333xx3333 @@ -658,9 +651,7 @@ pure function math_mul33x33(A,B) real(pReal), dimension(3,3), intent(in) :: A,B integer(pInt) :: i,j - do concurrent(i=1_pInt:3_pInt,j=1_pInt:3_pInt) - math_mul33x33(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) - enddo + forall(i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_mul33x33(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) end function math_mul33x33 @@ -675,10 +666,9 @@ pure function math_mul66x66(A,B) real(pReal), dimension(6,6), intent(in) :: A,B integer(pInt) :: i,j - do concurrent(i=1_pInt:6_pInt,j=1_pInt:6_pInt) + forall(i=1_pInt:6_pInt,j=1_pInt:6_pInt) & math_mul66x66(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) & + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) - enddo end function math_mul66x66 @@ -693,11 +683,10 @@ pure function math_mul99x99(A,B) real(pReal), dimension(9,9), intent(in) :: A,B integer(pInt) i,j - do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + forall(i=1_pInt:9_pInt,j=1_pInt:9_pInt) & math_mul99x99(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) & + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) & + A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) - enddo end function math_mul99x99 @@ -745,9 +734,8 @@ pure function math_mul66x6(A,B) real(pReal), dimension(6), intent(in) :: B integer(pInt) :: i - forall (i=1_pInt:6_pInt) math_mul66x6(i) = & - A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + & - A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6) + forall (i=1_pInt:6_pInt) math_mul66x6(i) = A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) & + + A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6) end function math_mul66x6 @@ -1113,7 +1101,7 @@ pure function math_33to9(m33) integer(pInt) :: i - forall (i=1_pInt:9_pInt) math_33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) + forall(i=1_pInt:9_pInt) math_33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) end function math_33to9 @@ -1129,7 +1117,7 @@ pure function math_9to33(v9) integer(pInt) :: i - forall (i=1_pInt:9_pInt) math_9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) + forall(i=1_pInt:9_pInt) math_9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) end function math_9to33 @@ -1156,7 +1144,7 @@ pure function math_33to6(m33,weighted) w = nrmMandel endif - forall (i=1_pInt:6_pInt) math_33to6(i) = w(i)*m33(mapNye(1,i),mapNye(2,i)) + forall(i=1_pInt:6_pInt) math_33to6(i) = w(i)*m33(mapNye(1,i),mapNye(2,i)) end function math_33to6 @@ -1202,9 +1190,8 @@ pure function math_3333to99(m3333) integer(pInt) :: i,j - do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + forall(i=1_pInt:9_pInt,j=1_pInt:9_pInt) & math_3333to99(i,j) = m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) - enddo end function math_3333to99 @@ -1220,9 +1207,8 @@ pure function math_99to3333(m99) integer(pInt) :: i,j - do concurrent(i=1_pInt:9_pInt,j=1_pInt:9_pInt) + forall(i=1_pInt:9_pInt,j=1_pInt:9_pInt) & math_99to3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) = m99(i,j) - enddo end function math_99to3333 @@ -1249,9 +1235,8 @@ pure function math_3333to66(m3333,weighted) w = nrmMandel endif - do concurrent(i=1_pInt:6_pInt,j=1_pInt:6_pInt) + forall(i=1_pInt:6_pInt,j=1_pInt:6_pInt) & math_3333to66(i,j) = w(i)*w(j)*m3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) - enddo end function math_3333to66 @@ -1711,9 +1696,7 @@ pure function math_qToR(q) real(pReal), dimension(3,3) :: math_qToR, T,S integer(pInt) :: i, j - do concurrent (i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) - T(i,j) = q(i+1_pInt) * q(j+1_pInt) - enddo + forall(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) T(i,j) = q(i+1_pInt) * q(j+1_pInt) S = reshape( [0.0_pReal, -q(4), q(3), & q(4), 0.0_pReal, -q(2), & From 3b27af3f946470f8d386920598cb5d99d5113cc7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 10:39:38 +0100 Subject: [PATCH 217/372] cross-checking with Danny's thesis --- src/CPFEM.f90 | 42 ++++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 847688d57..515b28ab0 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -286,12 +286,11 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt math_identity2nd, & math_mul33x33, & math_det33, & - math_transpose33, & - math_I3, & - math_Mandel3333to66, & - math_Mandel66to3333, & - math_Mandel33to6, & - math_Mandel6to33 + math_delta, & + math_3333to66, & + math_66to3333, & + math_33to6, & + math_6to33 use mesh, only: & mesh_FEasCP, & mesh_NcpElems, & @@ -353,8 +352,8 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt integer(pInt), intent(in) :: mode !< computation mode 1: regular computation plus aging of results real(pReal), intent(in) :: temperature_inp !< temperature logical, intent(in) :: parallelExecution !< flag indicating parallel computation of requested IPs - real(pReal), dimension(6), intent(out) :: cauchyStress !< stress vector in Mandel notation - real(pReal), dimension(6,6), intent(out) :: jacobian !< jacobian in Mandel notation (Consistent tangent dcs/dE) + real(pReal), dimension(6), intent(out) :: cauchyStress !< stress as 6 vector + real(pReal), dimension(6,6), intent(out) :: jacobian !< jacobian as 66 tensor (Consistent tangent dcs/dE) real(pReal) J_inverse, & ! inverse of Jacobian rnd @@ -534,8 +533,8 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) then write(6,'(a,1x,i8,1x,i2)') '<< CPFEM >> OUTDATED at elFE ip',elFE,ip write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 old:',& - math_transpose33(materialpoint_F(1:3,1:3,ip,elCP)) - write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 now:',math_transpose33(ffn1) + transpose(materialpoint_F(1:3,1:3,ip,elCP)) + write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 now:',transpose(ffn1) endif outdatedFFN1 = .true. endif @@ -593,26 +592,25 @@ 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), math_transpose33(materialpoint_F(1:3,1:3,ip,elCP))) + Kirchhoff = math_mul33x33(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_Mandel33to6(J_inverse * Kirchhoff) + CPFEM_cs(1:6,ip,elCP) = math_33to6(J_inverse * Kirchhoff) ! translate from dP/dF to dCS/dE H = 0.0_pReal do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3 - H(i,j,k,l) = H(i,j,k,l) + & - materialpoint_F(j,m,ip,elCP) * & - materialpoint_F(l,n,ip,elCP) * & - materialpoint_dPdF(i,m,k,n,ip,elCP) - & - math_I3(j,l) * materialpoint_F(i,m,ip,elCP) * materialpoint_P(k,m,ip,elCP) + & - 0.5_pReal * (math_I3(i,k) * Kirchhoff(j,l) + math_I3(j,l) * Kirchhoff(i,k) + & - math_I3(i,l) * Kirchhoff(j,k) + math_I3(j,k) * Kirchhoff(i,l)) + H(i,j,k,l) = H(i,j,k,l) & + + materialpoint_F(j,m,ip,elCP) * materialpoint_F(l,n,ip,elCP) & + * materialpoint_dPdF(i,m,k,n,ip,elCP) & + - math_delta(j,l) * materialpoint_F(i,m,ip,elCP) * materialpoint_P(k,m,ip,elCP) & + + 0.5_pReal * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) & + + Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k)) enddo; enddo; enddo; enddo; enddo; enddo forall(i=1:3, j=1:3,k=1:3,l=1:3) & H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) - CPFEM_dcsde(1:6,1:6,ip,elCP) = math_Mandel3333to66(J_inverse * H_sym) + CPFEM_dcsde(1:6,1:6,ip,elCP) = math_3333to66(J_inverse * H_sym) endif terminalIllness endif validCalculation @@ -639,7 +637,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt !*** remember extreme values of stress ... - cauchyStress33 = math_Mandel6to33(CPFEM_cs(1:6,ip,elCP)) + cauchyStress33 = math_6to33(CPFEM_cs(1:6,ip,elCP)) if (maxval(cauchyStress33) > debug_stressMax) then debug_stressMaxLocation = [elCP, ip] debug_stressMax = maxval(cauchyStress33) @@ -649,7 +647,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt debug_stressMin = minval(cauchyStress33) endif !*** ... and Jacobian - jacobian3333 = math_Mandel66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP)) + jacobian3333 = math_66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP)) if (maxval(jacobian3333) > debug_jacobianMax) then debug_jacobianMaxLocation = [elCP, ip] debug_jacobianMax = maxval(jacobian3333) From adb68ff7927d6dc8a43604ab0e96fcab15a823b9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 12:45:07 +0100 Subject: [PATCH 218/372] avoid converstions and use of global variables --- PRIVATE | 2 +- src/CPFEM.f90 | 8 ++++---- src/DAMASK_abaqus.f | 8 +++----- src/DAMASK_marc.f90 | 11 ++++------- src/math.f90 | 12 ++++++------ 5 files changed, 18 insertions(+), 23 deletions(-) diff --git a/PRIVATE b/PRIVATE index 5ed6a1f60..6e7550042 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 5ed6a1f60b412eb46ff6820cf03b684095ff1f75 +Subproject commit 6e7550042259f46992329d202f5804df48ce99ff diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 515b28ab0..11bfd8be7 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -594,7 +594,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt ! 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))) J_inverse = 1.0_pReal / math_det33(materialpoint_F(1:3,1:3,ip,elCP)) - CPFEM_cs(1:6,ip,elCP) = math_33to6(J_inverse * Kirchhoff) + CPFEM_cs(1:6,ip,elCP) = math_33to6(J_inverse * Kirchhoff,weighted=.false.) ! translate from dP/dF to dCS/dE H = 0.0_pReal @@ -610,7 +610,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt forall(i=1:3, j=1:3,k=1:3,l=1:3) & H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) - CPFEM_dcsde(1:6,1:6,ip,elCP) = math_3333to66(J_inverse * H_sym) + CPFEM_dcsde(1:6,1:6,ip,elCP) = math_3333to66(J_inverse * H_sym,weighted=.false.) endif terminalIllness endif validCalculation @@ -637,7 +637,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt !*** remember extreme values of stress ... - cauchyStress33 = math_6to33(CPFEM_cs(1:6,ip,elCP)) + cauchyStress33 = math_6to33(CPFEM_cs(1:6,ip,elCP),weighted=.false.) if (maxval(cauchyStress33) > debug_stressMax) then debug_stressMaxLocation = [elCP, ip] debug_stressMax = maxval(cauchyStress33) @@ -647,7 +647,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt debug_stressMin = minval(cauchyStress33) endif !*** ... and Jacobian - jacobian3333 = math_66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP)) + jacobian3333 = math_66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP),weighted=.false.) if (maxval(jacobian3333) > debug_jacobianMax) then debug_jacobianMaxLocation = [elCP, ip] debug_jacobianMax = maxval(jacobian3333) diff --git a/src/DAMASK_abaqus.f b/src/DAMASK_abaqus.f index 6c6434e4a..9072de95d 100644 --- a/src/DAMASK_abaqus.f +++ b/src/DAMASK_abaqus.f @@ -102,8 +102,6 @@ subroutine UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,& calcMode, & terminallyIll, & symmetricSolver - use math, only: & - invnrmMandel use debug, only: & debug_info, & debug_reset, & @@ -305,9 +303,9 @@ subroutine UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,& ! ABAQUS implicit: 11, 22, 33, 12, 13, 23 ! ABAQUS implicit: 11, 22, 33, 12 - forall(i=1:ntens) ddsdde(1:ntens,i) = invnrmMandel(i)*ddsdde_h(1:ntens,i)*invnrmMandel(1:ntens) - stress(1:ntens) = stress_h(1:ntens)*invnrmMandel(1:ntens) - if(symmetricSolver) ddsdde(1:ntens,1:ntens) = 0.5_pReal*(ddsdde(1:ntens,1:ntens) + transpose(ddsdde(1:ntens,1:ntens))) + ddsdde = ddsdde_h(1:ntens,1:ntens) + stress = stress_h(1:ntens) + if(symmetricSolver) ddsdde = 0.5_pReal*(ddsdde + transpose(ddsdde)) if(ntens == 6) then stress_h = stress stress(5) = stress_h(6) diff --git a/src/DAMASK_marc.f90 b/src/DAMASK_marc.f90 index f3130c5cd..0c7d1adeb 100644 --- a/src/DAMASK_marc.f90 +++ b/src/DAMASK_marc.f90 @@ -127,9 +127,6 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & calcMode, & terminallyIll, & symmetricSolver - use math, only: & - math_transpose33,& - invnrmMandel use debug, only: & debug_level, & debug_LEVELBASIC, & @@ -235,9 +232,9 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & write(6,'(a,i12)') ' Nodes: ', nnode write(6,'(a,i1)') ' Deformation gradient: ', itel write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n:', & - math_transpose33(ffn) + transpose(ffn) write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', & - math_transpose33(ffn1) + transpose(ffn1) endif !$ defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc @@ -357,8 +354,8 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & ! Marc: 11, 22, 33, 12, 23, 13 ! Marc: 11, 22, 33, 12 - forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*ddsdde(1:ngens,i)*invnrmMandel(1:ngens) - s(1:ndi+nshear) = stress(1:ndi+nshear)*invnrmMandel(1:ndi+nshear) + d = ddsdde(1:ngens,1:ngens) + s = stress(1:ndi+nshear) g = 0.0_pReal if(symmetricSolver) d = 0.5_pReal*(d+transpose(d)) diff --git a/src/math.f90 b/src/math.f90 index 3d60eba0c..1b782dce2 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -29,7 +29,7 @@ module math 1.0_pReal, 1.0_pReal, 1.0_pReal, & sqrt(2.0_pReal), sqrt(2.0_pReal), sqrt(2.0_pReal) ] !< weighting for Mandel notation (forward) - real(pReal), dimension(6), parameter , public :: & + real(pReal), dimension(6), parameter , private :: & invnrmMandel = [& 1.0_pReal, 1.0_pReal, 1.0_pReal, & 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal) ] !< weighting for Mandel notation (backward) @@ -1180,7 +1180,7 @@ end function math_6to33 !-------------------------------------------------------------------------------------------------- -!> @brief convert 3333 matrix into vector 99 +!> @brief convert 3333 matrix into 99 matrix !-------------------------------------------------------------------------------------------------- pure function math_3333to99(m3333) @@ -1197,7 +1197,7 @@ end function math_3333to99 !-------------------------------------------------------------------------------------------------- -!> @brief convert 99 vector into 3333 matrix +!> @brief convert 99 matrix into 3333 matrix !-------------------------------------------------------------------------------------------------- pure function math_99to3333(m99) @@ -1214,7 +1214,7 @@ end function math_99to3333 !-------------------------------------------------------------------------------------------------- -!> @brief convert symmetric 3333 matrix into 66 vector +!> @brief convert symmetric 3333 matrix into 66 matrix !> @details Weighted conversion (default) rearranges according to Nye and weights shear ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye @@ -1242,7 +1242,7 @@ end function math_3333to66 !-------------------------------------------------------------------------------------------------- -!> @brief convert 66 vector into symmetric 3333 matrix +!> @brief convert 66 matrix into symmetric 3333 matrix !> @details Weighted conversion (default) rearranges according to Nye and weights shear ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye @@ -1274,7 +1274,7 @@ end function math_66to3333 !-------------------------------------------------------------------------------------------------- -!> @brief convert Voigt matrix 66 back to symmetric 3333 tensor +!> @brief convert 66 Voigt matrix into symmetric 3333 matrix !-------------------------------------------------------------------------------------------------- pure function math_Voigt66to3333(m66) From 43f9d043d2b8b92363964e22b0c907806011a170 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 12:56:46 +0100 Subject: [PATCH 219/372] removed time syncing --- src/crystallite.f90 | 286 ++------------------------------------------ src/numerics.f90 | 5 - 2 files changed, 7 insertions(+), 284 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 50757cb29..86348db4e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -80,8 +80,6 @@ module crystallite logical, dimension(:,:), allocatable, private :: & crystallite_clearToWindForward, & !< description not available crystallite_clearToCutback, & !< description not available - crystallite_syncSubFrac, & !< description not available - crystallite_syncSubFracCompleted, & !< description not available crystallite_neighborEnforcedCutback !< description not available enum, bind(c) @@ -248,8 +246,6 @@ subroutine crystallite_init allocate(crystallite_todo(cMax,iMax,eMax), source=.false.) allocate(crystallite_converged(cMax,iMax,eMax), source=.true.) allocate(crystallite_clearToWindForward(iMax,eMax), source=.true.) - allocate(crystallite_syncSubFrac(iMax,eMax), source=.false.) - allocate(crystallite_syncSubFracCompleted(iMax,eMax), source=.false.) allocate(crystallite_clearToCutback(iMax,eMax), source=.true.) allocate(crystallite_neighborEnforcedCutback(iMax,eMax), source=.false.) allocate(crystallite_output(maxval(crystallite_Noutput), & @@ -444,8 +440,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) use numerics, only: & subStepMinCryst, & subStepSizeCryst, & - stepIncreaseCryst, & - numerics_timeSyncing + stepIncreaseCryst #ifdef DEBUG use debug, only: & debug_level, & @@ -600,235 +595,6 @@ subroutine crystallite_stressAndItsTangent(updateJaco) if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & write(6,'(a,i6)') '<< CRYST >> crystallite iteration ',NiterationCrystallite #endif - timeSyncing1: if (any(.not. crystallite_localPlasticity) .and. numerics_timeSyncing) then - - ! Time synchronization can only be used for nonlocal calculations, and only there it makes sense. - ! The idea is that in nonlocal calculations often the vast majority of the ips - ! converges in one iteration whereas a small fraction of ips has to do a lot of cutbacks. - ! Hence, we try to minimize the computational effort by just doing a lot of cutbacks - ! in the vicinity of the "bad" ips and leave the easily converged volume more or less as it is. - ! However, some synchronization of the time step has to be done at the border between "bad" ips - ! and the ones that immediately converged. - - if (any(crystallite_syncSubFrac)) then - - ! Just did a time synchronization. - ! If all synchronizers converged, then do nothing else than winding them forward. - ! If any of the synchronizers did not converge, something went completely wrong - ! and its not clear how to fix this, so all nonlocals become terminally ill. - - if (any(crystallite_syncSubFrac .and. .not. crystallite_converged(1,:,:))) then -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if (crystallite_syncSubFrac(i,e) .and. .not. crystallite_converged(1,i,e)) & - write(6,'(a,i8,1x,i2)') '<< CRYST >> time synchronization: failed at el,ip ',e,i - enddo - enddo - endif -#endif - crystallite_syncSubFrac = .false. - where(.not. crystallite_localPlasticity) - crystallite_substep = 0.0_pReal - crystallite_todo = .false. - endwhere - else - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_syncSubFrac(i,e) - crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) - enddo - enddo - !$OMP END PARALLEL DO -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> time synchronization: wind forward' -#endif - endif - - elseif (any(crystallite_syncSubFracCompleted)) then - - ! Just completed a time synchronization. - ! Make sure that the ips that synchronized their time step start non-converged - - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if (crystallite_syncSubFracCompleted(i,e)) crystallite_converged(1,i,e) = .false. - crystallite_syncSubFracCompleted(i,e) = .false. - crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) - crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) .or. .not. crystallite_converged(1,i,e) - enddo - enddo -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> time synchronization: done, proceed with cutback' -#endif - else - - ! Normal calculation. - ! If all converged and are at the end of the time increment, then just do a final wind forward. - ! If all converged, but not all reached the end of the time increment, then we only wind - ! those forward that are still on their way, all others have to wait. - ! If some did not converge and all are still at the start of the time increment, - ! then all non-convergers force their converged neighbors to also do a cutback. - ! In case that some ips have already wound forward to an intermediate time (subfrac), - ! then all those ips that converged in the first iteration, but now have a non-converged neighbor - ! have to synchronize their time step to the same intermediate time. If such a synchronization - ! takes place, all other ips have to wait and only the synchronizers do a cutback. In the next - ! iteration those will do a wind forward while all others still wait. - - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) - crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) - enddo - enddo - !$OMP END PARALLEL DO - if (all(crystallite_localPlasticity .or. crystallite_converged)) then - if (all(crystallite_localPlasticity .or. crystallite_subStep + crystallite_subFrac >= 1.0_pReal)) then - crystallite_clearToWindForward = .true. ! final wind forward -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> final wind forward' -#endif - else - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_subStep(1,i,e) < 1.0_pReal - enddo - enddo - !$OMP END PARALLEL DO -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> wind forward' -#endif - endif - else - subFracIntermediate = maxval(crystallite_subFrac, mask=.not.crystallite_localPlasticity) - if (dNeq0(subFracIntermediate)) then - crystallite_neighborEnforcedCutback = .false. ! look for ips that require a cutback because of a nonconverged neighbor - !$OMP PARALLEL - !$OMP DO PRIVATE(neighboring_e,neighboring_i) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if (.not. crystallite_localPlasticity(1,i,e) .and. crystallite_converged(1,i,e)) then - do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) - neighboring_e = mesh_ipNeighborhood(1,n,i,e) - neighboring_i = mesh_ipNeighborhood(2,n,i,e) - if (neighboring_e > 0_pInt .and. neighboring_i > 0_pInt) then - if (.not. crystallite_localPlasticity(1,neighboring_i,neighboring_e) & - .and. .not. crystallite_converged(1,neighboring_i,neighboring_e)) then - crystallite_neighborEnforcedCutback(i,e) = .true. -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a12,i5,1x,i2,a,i5,1x,i2)') '<< CRYST >> ', neighboring_e,neighboring_i, & - ' enforced cutback at ',e,i -#endif - exit - endif - endif - enddo - endif - enddo - enddo - !$OMP END DO - !$OMP DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if(crystallite_neighborEnforcedCutback(i,e)) crystallite_converged(1,i,e) = .false. - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - else - crystallite_syncSubFrac = .false. ! look for ips that have to do a time synchronization because of a nonconverged neighbor - !$OMP PARALLEL - !$OMP DO PRIVATE(neighboring_e,neighboring_i) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if (.not. crystallite_localPlasticity(1,i,e) .and. dNeq0(crystallite_subFrac(1,i,e))) then - do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) - neighboring_e = mesh_ipNeighborhood(1,n,i,e) - neighboring_i = mesh_ipNeighborhood(2,n,i,e) - if (neighboring_e > 0_pInt .and. neighboring_i > 0_pInt) then - if (.not. crystallite_localPlasticity(1,neighboring_i,neighboring_e) & - .and. .not. crystallite_converged(1,neighboring_i,neighboring_e)) then - crystallite_syncSubFrac(i,e) = .true. -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a12,i5,1x,i2,a,i5,1x,i2)') '<< CRYST >> ',neighboring_e,neighboring_i, & - ' enforced time synchronization at ',e,i -#endif - exit - endif - endif - enddo - endif - enddo - enddo - !$OMP END DO - !$OMP DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if(crystallite_syncSubFrac(i,e)) crystallite_converged(1,i,e) = .false. - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - endif - where(.not. crystallite_localPlasticity .and. crystallite_subStep < 1.0_pReal) & - crystallite_converged = .false. - if (any(crystallite_syncSubFrac)) then ! have to do syncing now, so all wait except for the synchronizers which do a cutback - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) - crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_syncSubFrac(i,e) - enddo - enddo - !$OMP END PARALLEL DO -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> time synchronization: cutback' -#endif - else - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if(.not. crystallite_converged(1,i,e)) crystallite_clearToCutback(i,e) = .true. - enddo - enddo - !$OMP END PARALLEL DO -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> cutback' -#endif - endif - endif - endif - - ! Make sure that all cutbackers start with the same substep - - where(.not. crystallite_localPlasticity .and. .not. crystallite_converged) & - crystallite_subStep = minval(crystallite_subStep, mask=.not. crystallite_localPlasticity & - .and. .not. crystallite_converged) - - ! Those that do neither wind forward nor cutback are not to do - - !$OMP PARALLEL DO - elementLooping2: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if(.not. crystallite_clearToWindForward(i,e) .and. .not. crystallite_clearToCutback(i,e)) & - crystallite_todo(1,i,e) = .false. - enddo - enddo elementLooping2 - !$OMP END PARALLEL DO - - endif timeSyncing1 !$OMP PARALLEL DO PRIVATE(formerSubStep) elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) @@ -856,13 +622,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) enddo crystallite_subTstar0_v(1:6,c,i,e) = crystallite_Tstar_v(1:6,c,i,e) ! ...2nd PK stress - if (crystallite_syncSubFrac(i,e)) then ! if we just did a synchronization of states, then we wind forward without any further time integration - crystallite_syncSubFracCompleted(i,e) = .true. - crystallite_syncSubFrac(i,e) = .false. - crystallite_todo(c,i,e) = .false. - else - crystallite_todo(c,i,e) = .true. - endif + crystallite_todo(c,i,e) = .true. #ifdef DEBUG if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt & .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & @@ -878,11 +638,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) ! --- cutback --- elseif (.not. crystallite_converged(c,i,e) .and. crystallite_clearToCutback(i,e)) then - if (crystallite_syncSubFrac(i,e)) then ! synchronize time - crystallite_subStep(c,i,e) = subFracIntermediate - else - crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) ! cut step in half and restore... - endif + crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) ! cut step in half and restore... crystallite_Fp(1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) ! ...plastic def grad 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) ! ...intermediate def grad @@ -933,29 +689,6 @@ subroutine crystallite_stressAndItsTangent(updateJaco) enddo elementLooping3 !$OMP END PARALLEL DO - timeSyncing2: if(numerics_timeSyncing) then - if (any(.not. crystallite_localPlasticity .and. .not. crystallite_todo .and. .not. crystallite_converged & - .and. crystallite_subStep <= subStepMinCryst)) then ! no way of rescuing a nonlocal ip that violated the lower time step limit, ... -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then - elementLooping4: 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_localPlasticity(c,i,e) .and. .not. crystallite_todo(c,i,e) & - .and. .not. crystallite_converged(c,i,e) .and. crystallite_subStep(c,i,e) <= subStepMinCryst) & - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> nonlocal violated minimum subStep at el ip ipc ',e,i,c - enddo - enddo - enddo elementLooping4 - endif -#endif - where(.not. crystallite_localPlasticity) - crystallite_todo = .false. ! ... so let all nonlocal ips die peacefully - crystallite_subStep = 0.0_pReal - endwhere - endif - endif timeSyncing2 - #ifdef DEBUG if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then write(6,'(/,a,f8.5)') '<< CRYST >> min(subStep) ',minval(crystallite_subStep) @@ -2268,8 +2001,6 @@ subroutine integrateStateEuler() debug_levelExtensive, & debug_levelSelective #endif - use numerics, only: & - numerics_timeSyncing use FEsolving, only: & FEsolving_execElem, & FEsolving_execIP @@ -2340,7 +2071,7 @@ eIter = FEsolving_execElem(1:2) NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) enddo if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e) .and. .not. numerics_timeSyncing) then ! if broken non-local... + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... !$OMP CRITICAL (checkTodo) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped !$OMP END CRITICAL (checkTodo) @@ -2397,8 +2128,7 @@ eIter = FEsolving_execElem(1:2) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then crystallite_todo(g,i,e) = stateJump(g,i,e) !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e) & ! if broken non-local... - .and. .not. numerics_timeSyncing) then + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... !$OMP CRITICAL (checkTodo) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped !$OMP END CRITICAL (checkTodo) @@ -2431,8 +2161,7 @@ eIter = FEsolving_execElem(1:2) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then crystallite_todo(g,i,e) = integrateStress(g,i,e) !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e) & ! if broken non-local... - .and. .not. numerics_timeSyncing) then + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... !$OMP CRITICAL (checkTodo) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped !$OMP END CRITICAL (checkTodo) @@ -2456,8 +2185,7 @@ eIter = FEsolving_execElem(1:2) ! --- CHECK NON-LOCAL CONVERGENCE --- if (.not. singleRun) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) & ! any non-local not yet converged (or broken)... - .and. .not. numerics_timeSyncing) & + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged endif diff --git a/src/numerics.f90 b/src/numerics.f90 index e4ceec622..9e585dda7 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -276,8 +276,6 @@ subroutine numerics_init numerics_integrator = IO_intValue(line,chunkPos,2_pInt) case ('usepingpong') usepingpong = IO_intValue(line,chunkPos,2_pInt) > 0_pInt - case ('timesyncing') - numerics_timeSyncing = IO_intValue(line,chunkPos,2_pInt) > 0_pInt case ('unitlength') numerics_unitlength = IO_floatValue(line,chunkPos,2_pInt) @@ -454,8 +452,6 @@ subroutine numerics_init end select #endif - numerics_timeSyncing = numerics_timeSyncing .and. all(numerics_integrator==2_pInt) ! timeSyncing only allowed for explicit Euler integrator - !-------------------------------------------------------------------------------------------------- ! writing parameters to output write(6,'(a24,1x,es8.1)') ' relevantStrain: ',relevantStrain @@ -476,7 +472,6 @@ subroutine numerics_init write(6,'(a24,1x,es8.1)') ' rTol_crystalliteStress: ',rTol_crystalliteStress write(6,'(a24,1x,es8.1)') ' aTol_crystalliteStress: ',aTol_crystalliteStress write(6,'(a24,2(1x,i8))') ' integrator: ',numerics_integrator - write(6,'(a24,1x,L8)') ' timeSyncing: ',numerics_timeSyncing write(6,'(a24,1x,L8)') ' use ping pong scheme: ',usepingpong write(6,'(a24,1x,es8.1,/)')' unitlength: ',numerics_unitlength From 54bb6a5eb67447d3cfa4d15e4b339e941adbd6af Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 16:36:08 +0100 Subject: [PATCH 220/372] more verbose name credits to Franz --- src/CPFEM.f90 | 16 +++++++------- src/math.f90 | 60 +++++++++++++++++++++++++-------------------------- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 11bfd8be7..0cc51e4fc 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -287,10 +287,10 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt math_mul33x33, & math_det33, & math_delta, & - math_3333to66, & - math_66to3333, & - math_33to6, & - math_6to33 + math_sym3333to66, & + math_66toSym3333, & + math_sym33to6, & + math_6toSym33 use mesh, only: & mesh_FEasCP, & mesh_NcpElems, & @@ -594,7 +594,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt ! 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))) J_inverse = 1.0_pReal / math_det33(materialpoint_F(1:3,1:3,ip,elCP)) - CPFEM_cs(1:6,ip,elCP) = math_33to6(J_inverse * Kirchhoff,weighted=.false.) + CPFEM_cs(1:6,ip,elCP) = math_sym33to6(J_inverse * Kirchhoff,weighted=.false.) ! translate from dP/dF to dCS/dE H = 0.0_pReal @@ -610,7 +610,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt forall(i=1:3, j=1:3,k=1:3,l=1:3) & H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) - CPFEM_dcsde(1:6,1:6,ip,elCP) = math_3333to66(J_inverse * H_sym,weighted=.false.) + CPFEM_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.) endif terminalIllness endif validCalculation @@ -637,7 +637,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt !*** remember extreme values of stress ... - cauchyStress33 = math_6to33(CPFEM_cs(1:6,ip,elCP),weighted=.false.) + cauchyStress33 = math_6toSym33(CPFEM_cs(1:6,ip,elCP),weighted=.false.) if (maxval(cauchyStress33) > debug_stressMax) then debug_stressMaxLocation = [elCP, ip] debug_stressMax = maxval(cauchyStress33) @@ -647,7 +647,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt debug_stressMin = minval(cauchyStress33) endif !*** ... and Jacobian - jacobian3333 = math_66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP),weighted=.false.) + jacobian3333 = math_66toSym3333(CPFEM_dcsdE(1:6,1:6,ip,elCP),weighted=.false.) if (maxval(jacobian3333) > debug_jacobianMax) then debug_jacobianMaxLocation = [elCP, ip] debug_jacobianMax = maxval(jacobian3333) diff --git a/src/math.f90 b/src/math.f90 index 1b782dce2..682f3b78e 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -83,11 +83,11 @@ module math end interface math_Plain9to33 interface math_Mandel33to6 - module procedure math_33to6 + module procedure math_sym33to6 end interface math_Mandel33to6 interface math_Mandel6to33 - module procedure math_6to33 + module procedure math_6toSym33 end interface math_Mandel6to33 interface math_Plain3333to99 @@ -99,11 +99,11 @@ module math end interface math_Plain99to3333 interface math_Mandel3333to66 - module procedure math_3333to66 + module procedure math_sym3333to66 end interface math_Mandel3333to66 interface math_Mandel66to3333 - module procedure math_66to3333 + module procedure math_66toSym3333 end interface math_Mandel66to3333 public :: & @@ -156,12 +156,12 @@ module math math_det33, & math_33to9, & math_9to33, & - math_33to6, & - math_6to33, & + math_sym33to6, & + math_6toSym33, & math_3333to99, & math_99to3333, & - math_3333to66, & - math_66to3333, & + math_sym3333to66, & + math_66toSym3333, & math_Voigt66to3333, & math_qRand, & math_qMul, & @@ -878,11 +878,11 @@ function math_invSym3333(A) dgetrf, & dgetri - temp66_real = math_3333to66(A) + temp66_real = math_sym3333to66(A) call dgetrf(6,6,temp66_real,6,ipiv6,ierr) call dgetri(6,temp66_real,6,ipiv6,work6,6,ierr) if (ierr == 0_pInt) then - math_invSym3333 = math_66to3333(temp66_real) + math_invSym3333 = math_66toSym3333(temp66_real) else call IO_error(400_pInt, ext_msg = 'math_invSym3333') endif @@ -1128,10 +1128,10 @@ end function math_9to33 ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_33to6(m33,weighted) +pure function math_sym33to6(m33,weighted) implicit none - real(pReal), dimension(6) :: math_33to6 + real(pReal), dimension(6) :: math_sym33to6 real(pReal), dimension(3,3), intent(in) :: m33 logical, optional, intent(in) :: weighted @@ -1144,9 +1144,9 @@ pure function math_33to6(m33,weighted) w = nrmMandel endif - forall(i=1_pInt:6_pInt) math_33to6(i) = w(i)*m33(mapNye(1,i),mapNye(2,i)) + forall(i=1_pInt:6_pInt) math_sym33to6(i) = w(i)*m33(mapNye(1,i),mapNye(2,i)) -end function math_33to6 +end function math_sym33to6 !-------------------------------------------------------------------------------------------------- @@ -1155,10 +1155,10 @@ end function math_33to6 ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_6to33(v6,weighted) +pure function math_6toSym33(v6,weighted) implicit none - real(pReal), dimension(3,3) :: math_6to33 + real(pReal), dimension(3,3) :: math_6toSym33 real(pReal), dimension(6), intent(in) :: v6 logical, optional, intent(in) :: weighted @@ -1172,11 +1172,11 @@ pure function math_6to33(v6,weighted) endif do i=1_pInt,6_pInt - math_6to33(mapNye(1,i),mapNye(2,i)) = w(i)*v6(i) - math_6to33(mapNye(2,i),mapNye(1,i)) = w(i)*v6(i) + math_6toSym33(mapNye(1,i),mapNye(2,i)) = w(i)*v6(i) + math_6toSym33(mapNye(2,i),mapNye(1,i)) = w(i)*v6(i) enddo -end function math_6to33 +end function math_6toSym33 !-------------------------------------------------------------------------------------------------- @@ -1219,10 +1219,10 @@ end function math_99to3333 ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_3333to66(m3333,weighted) +pure function math_sym3333to66(m3333,weighted) implicit none - real(pReal), dimension(6,6) :: math_3333to66 + real(pReal), dimension(6,6) :: math_sym3333to66 real(pReal), dimension(3,3,3,3), intent(in) :: m3333 logical, optional, intent(in) :: weighted @@ -1236,9 +1236,9 @@ pure function math_3333to66(m3333,weighted) endif forall(i=1_pInt:6_pInt,j=1_pInt:6_pInt) & - math_3333to66(i,j) = w(i)*w(j)*m3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) + math_sym3333to66(i,j) = w(i)*w(j)*m3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) -end function math_3333to66 +end function math_sym3333to66 !-------------------------------------------------------------------------------------------------- @@ -1247,10 +1247,10 @@ end function math_3333to66 ! components according to Mandel. Advisable for matrix operations. ! Unweighted conversion only changes order according to Nye !-------------------------------------------------------------------------------------------------- -pure function math_66to3333(m66,weighted) +pure function math_66toSym3333(m66,weighted) implicit none - real(pReal), dimension(3,3,3,3) :: math_66to3333 + real(pReal), dimension(3,3,3,3) :: math_66toSym3333 real(pReal), dimension(6,6), intent(in) :: m66 logical, optional, intent(in) :: weighted @@ -1264,13 +1264,13 @@ pure function math_66to3333(m66,weighted) endif do i=1_pInt,6_pInt; do j=1_pInt, 6_pInt - math_66to3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) - math_66to3333(mapNye(2,i),mapNye(1,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) - math_66to3333(mapNye(1,i),mapNye(2,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) - math_66to3333(mapNye(2,i),mapNye(1,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) + math_66toSym3333(mapNye(1,i),mapNye(2,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) + math_66toSym3333(mapNye(2,i),mapNye(1,i),mapNye(1,j),mapNye(2,j)) = w(i)*w(j)*m66(i,j) + math_66toSym3333(mapNye(1,i),mapNye(2,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) + math_66toSym3333(mapNye(2,i),mapNye(1,i),mapNye(2,j),mapNye(1,j)) = w(i)*w(j)*m66(i,j) enddo; enddo -end function math_66to3333 +end function math_66toSym3333 !-------------------------------------------------------------------------------------------------- From 3c12b7441f021db7f6049b7ebb86049c26a33d1b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 14 Jan 2019 19:36:32 +0100 Subject: [PATCH 221/372] used wrong tests --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 6e7550042..5ed6a1f60 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 6e7550042259f46992329d202f5804df48ce99ff +Subproject commit 5ed6a1f60b412eb46ff6820cf03b684095ff1f75 From 42c86b97113f8191b9d2171d3b7a94065506a121 Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 14 Jan 2019 22:43:54 +0100 Subject: [PATCH 222/372] [skip ci] updated version information after successful test of v2.0.2-1404-g3f40eeac --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 6deded9dc..d587bea54 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1397-gaaea11d9 +v2.0.2-1404-g3f40eeac From daaa7cc2ba30d6707c0133c707b378cfc7ea9847 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 15 Jan 2019 04:27:57 +0100 Subject: [PATCH 223/372] internal (private) functions at the end ordered state integrators according to their id --- src/crystallite.f90 | 3572 +++++++++++++++++++++---------------------- 1 file changed, 1786 insertions(+), 1786 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 86348db4e..7c8b02863 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -270,7 +270,6 @@ subroutine crystallite_init end select - do c = 1_pInt, size(config_crystallite) #if defined(__GFORTRAN__) str = ['GfortranBug86277'] @@ -871,1791 +870,6 @@ subroutine crystallite_stressAndItsTangent(updateJaco) end subroutine crystallite_stressAndItsTangent -!-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, state with 4th order explicit Runge Kutta method -!-------------------------------------------------------------------------------------------------- -subroutine integrateStateRK4() - use, intrinsic :: & - IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_NcpElems - use material, only: & - homogenization_Ngrains, & - plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt - use config, only: & - material_Nphase - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure - - implicit none - real(pReal), dimension(4), parameter :: & - TIMESTEPFRACTION = [0.5_pReal, 0.5_pReal, 1.0_pReal, 1.0_pReal] ! factor giving the fraction of the original timestep used for Runge Kutta Integration - 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 - i, & ! integration point index in ip loop - g, & ! grain index in grain loop - p, & ! phase loop - c, & - n, & - mySource, & - mySizePlasticDotState, & - mySizeSourceDotState - integer(pInt), dimension(2) :: eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - logical :: NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple - - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - -!-------------------------------------------------------------------------------------------------- -! initialize dotState - if (.not. singleRun) then - do p = 1_pInt, material_Nphase - plasticState(p)%RK4dotState = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RK4dotState = 0.0_pReal - enddo - enddo - else - e = eIter(1) - i = iIter(1,e) - do g = gIter(1,e), gIter(2,e) - plasticState(phaseAt(g,i,e))%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) - sourceState(phaseAt(g,i,e))%p(mySource)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal - enddo - enddo - endif - -!-------------------------------------------------------------------------------------------------- -! first Runge-Kutta step - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - c = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL -!-------------------------------------------------------------------------------------------------- -! --- SECOND TO FOURTH RUNGE KUTTA STEP PLUS FINAL INTEGRATION --- - - do n = 1_pInt,4_pInt - ! --- state update --- - - !$OMP PARALLEL - !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - plasticState(p)%RK4dotState(:,c) = plasticState(p)%RK4dotState(:,c) & - + weight(n)*plasticState(p)%dotState(:,c) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RK4dotState(:,c) = sourceState(p)%p(mySource)%RK4dotState(:,c) & - + weight(n)*sourceState(p)%p(mySource)%dotState(:,c) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state (1:mySizePlasticDotState,c) = & - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - + plasticState(p)%dotState (1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) * timeStepFraction(n) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) * timeStepFraction(n) - enddo - -#ifdef DEBUG - if (n == 4 & - .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then ! final integration step - - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) - endif -#endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- state jump --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- update dependent states --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- stress integration --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e,timeStepFraction(n)) ! fraction of original times step - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- dot state and RK dot state--- - - first3steps: if (n < 4) then - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - timeStepFraction(n)*crystallite_subdt(g,i,e), & ! fraction of original timestep - crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - endif first3steps - !$OMP END PARALLEL - - enddo - - - ! --- SET CONVERGENCE FLAG --- - - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem - enddo; enddo; enddo - - - ! --- CHECK NONLOCAL CONVERGENCE --- - - if (.not. singleRun) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) then ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif - endif - -end subroutine integrateStateRK4 - - -!-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, state with 5th order Runge-Kutta Cash-Karp method with -!> adaptive step size (use 5th order solution to advance = "local extrapolation") -!-------------------------------------------------------------------------------------------------- -subroutine integrateStateRKCK45() - use, intrinsic :: & - IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif - use numerics, only: & - rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_NcpElems, & - mesh_maxNips - use material, only: & - homogenization_Ngrains, & - plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt, & - homogenization_maxNgrains - use constitutive, only: & - constitutive_collectDotState, & - constitutive_plasticity_maxSizeDotState, & - constitutive_source_maxSizeDotState, & - constitutive_microstructure - - implicit none - real(pReal), dimension(5,5), parameter :: & - A = reshape([& - .2_pReal, .075_pReal, .3_pReal, -11.0_pReal/54.0_pReal, 1631.0_pReal/55296.0_pReal, & - .0_pReal, .225_pReal, -.9_pReal, 2.5_pReal, 175.0_pReal/512.0_pReal, & - .0_pReal, .0_pReal, 1.2_pReal, -70.0_pReal/27.0_pReal, 575.0_pReal/13824.0_pReal, & - .0_pReal, .0_pReal, .0_pReal, 35.0_pReal/27.0_pReal, 44275.0_pReal/110592.0_pReal, & - .0_pReal, .0_pReal, .0_pReal, .0_pReal, 253.0_pReal/4096.0_pReal], & - [5,5], order=[2,1]) !< coefficients in Butcher tableau (used for preliminary integration in stages 2 to 6) - - real(pReal), dimension(6), parameter :: & - B = & - [37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, & - 125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], & !< coefficients in Butcher tableau (used for final integration and error estimate) - DB = B - & - [2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,& - 13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 0.25_pReal] !< coefficients in Butcher tableau (used for final integration and error estimate) - - 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) :: & - e, & ! element index in element loop - i, & ! integration point index in ip loop - g, & ! grain index in grain loop - stage, & ! stage index in integration stage loop - s, & ! state index - n, & - p, & - cc, & - mySource, & - mySizePlasticDotState, & ! size of dot States - mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - - real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - plasticStateResiduum, & ! residuum from evolution in microstructure - relPlasticStateResiduum ! relative residuum from evolution in microstructure - real(pReal), dimension(constitutive_source_maxSizeDotState, & - maxval(phase_Nsources), & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - sourceStateResiduum, & ! residuum from evolution in microstructure - relSourceStateResiduum ! relative residuum from evolution in microstructure - logical :: & - NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple - - eIter = FEsolving_execElem(1:2) -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',1 -#endif - - ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - - - - ! --- FIRST RUNGE KUTTA STEP --- - - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,cc,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - cc = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - - ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- - - do stage = 1_pInt,5_pInt - - ! --- state update --- - - !$OMP PARALLEL - !$OMP DO PRIVATE(p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) ! store Runge-Kutta dotState - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,cc,n) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - - plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(mySource)%RKCK45dotState(1,:,cc) - enddo - do n = 2_pInt, stage - plasticState(p)%dotState(:,cc) = & - plasticState(p)%dotState(:,cc) + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%dotState(:,cc) = & - sourceState(p)%p(mySource)%dotState(:,cc) + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) - enddo - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState (p)%state (1:mySizePlasticDotState, cc) = & - plasticState (p)%subState0(1:mySizePlasticDotState, cc) & - + plasticState (p)%dotState (1:mySizePlasticDotState, cc) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc) & - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- state jump --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- update dependent states --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- stress integration --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e,C(stage)) ! fraction of original time step - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- dot state and RK dot state--- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',stage+1_pInt -#endif - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - C(stage)*crystallite_subdt(g,i,e), & ! fraction of original timestep - crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,cc,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - enddo - - -!-------------------------------------------------------------------------------------------------- -! --- STATE UPDATE WITH ERROR ESTIMATE FOR STATE --- - - relPlasticStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL - !$OMP DO PRIVATE(p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) ! store Runge-Kutta dotState - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - - ! --- absolute residuum in state --- - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)),DB) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & - matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & - * crystallite_subdt(g,i,e) - enddo - - ! --- dot state --- - plasticState(p)%dotState(:,cc) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%dotState(:,cc) = & - matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- state and update --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state (1:mySizePlasticDotState,cc) = & - plasticState(p)%subState0(1:mySizePlasticDotState,cc) & - + plasticState(p)%dotState (1:mySizePlasticDotState,cc) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc)& - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- relative residui and state convergence --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(s,cc)) > 0.0_pReal) & - relPlasticStateResiduum(s,g,i,e) = & - plasticStateResiduum(s,g,i,e) / plasticState(p)%state(s,cc) - - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(s,cc)) > 0.0_pReal) & - relSourceStateResiduum(s,mySource,g,i,e) = & - sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%state(s,cc) - enddo - crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) - enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt& - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i3,1x,i3,/)') '<< CRYST >> updateState at el ip ipc ',e,i,g - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & - relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', & - plasticState(p)%dotState(1:mySizePlasticDotState,cc) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & - plasticState(p)%state(1:mySizePlasticDotState,cc) - endif -#endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - -!-------------------------------------------------------------------------------------------------- -! --- UPDATE DEPENDENT STATES IF RESIDUUM BELOW TOLERANCE --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - - -!-------------------------------------------------------------------------------------------------- -! --- FINAL STRESS INTEGRATION STEP IF RESIDUUM BELOW TOLERANCE --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - -!-------------------------------------------------------------------------------------------------- -! --- SET CONVERGENCE FLAG --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - 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 ENDDO - - !$OMP END PARALLEL - - - ! --- nonlocal convergence check --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' ! if not requesting Integration of just a single IP -#endif - if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - -end subroutine integrateStateRKCK45 - - -!-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, state with 1st order Euler method with adaptive step size -!-------------------------------------------------------------------------------------------------- -subroutine integrateStateAdaptiveEuler() - use, intrinsic :: & - IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif - use numerics, only: & - rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_NcpElems, & - mesh_maxNips - use material, only: & - homogenization_Ngrains, & - plasticState, & - sourceState, & - phaseAt, phasememberAt, & - phase_Nsources, & - homogenization_maxNgrains - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure, & - constitutive_plasticity_maxSizeDotState, & - constitutive_source_maxSizeDotState - - implicit none - integer(pInt) :: & - e, & ! element index in element loop - i, & ! integration point index in ip loop - g, & ! grain index in grain loop - s, & ! state index - p, & - c, & - mySource, & - mySizePlasticDotState, & ! size of dot states - mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - plasticStateResiduum, & ! residuum from evolution in micrstructure - relPlasticStateResiduum ! relative residuum from evolution in microstructure - real(pReal), dimension(constitutive_source_maxSizeDotState,& - maxval(phase_Nsources), & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - sourceStateResiduum, & ! residuum from evolution in micrstructure - relSourceStateResiduum ! relative residuum from evolution in microstructure - - logical :: & - converged, & - NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple - - - ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - - - plasticStateResiduum = 0.0_pReal - relPlasticStateResiduum = 0.0_pReal - sourceStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal - - - !$OMP PARALLEL - ! --- DOT STATE (EULER INTEGRATION) --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- STATE UPDATE (EULER INTEGRATION) --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - - 0.5_pReal & - * plasticState(p)%dotstate(1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - plasticState(p)%state (1:mySizePlasticDotState,c) = & - plasticState(p)%state (1:mySizePlasticDotState,c) & - + plasticState(p)%dotstate(1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & - - 0.5_pReal & - * sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- UPDATE DEPENDENT STATES (EULER INTEGRATION) --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - - ! --- STRESS INTEGRATION (EULER INTEGRATION) --- - - !$OMP PARALLEL DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP END PARALLEL DO - - !$OMP PARALLEL - ! --- DOT STATE (HEUN METHOD) --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- ERROR ESTIMATE FOR STATE (HEUN METHOD) --- - - !$OMP SINGLE - relPlasticStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal - !$OMP END SINGLE - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - ! --- contribution of heun step to absolute residui --- - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) & - + 0.5_pReal * plasticState(p)%dotState(:,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) & - + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - enddo - - ! --- relative residui --- - forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & - relPlasticStateResiduum(s,g,i,e) = & - plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & - relSourceStateResiduum(s,mySource,g,i,e) = & - sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) - enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & - relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) & - - 2.0_pReal * plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / crystallite_subdt(g,i,e) ! calculate former dotstate from higher order solution and state residuum - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) - endif -#endif - - ! --- converged ? --- - converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - converged = converged .and. & - all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) - enddo - if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definitionem - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - - ! --- NONLOCAL CONVERGENCE CHECK --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' -#endif - if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - - -end subroutine integrateStateAdaptiveEuler - - -!-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, and state with 1st order explicit Euler method -!-------------------------------------------------------------------------------------------------- -subroutine integrateStateEuler() - use, intrinsic :: & - IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_NcpElems - use material, only: & - plasticState, & - sourceState, & - phaseAt, phasememberAt, & - phase_Nsources, & - homogenization_Ngrains - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure - - implicit none - - integer(pInt) :: & - e, & ! element index in element loop - i, & ! integration point index in ip loop - g, & ! grain index in grain loop - p, & ! phase loop - c, & - mySource, & - mySizePlasticDotState, & - mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - logical :: & - NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple - - -eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - - !$OMP PARALLEL - - ! --- DOT STATE --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - c = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- UPDATE STATE --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state( 1:mySizePlasticDotState,c) = & - plasticState(p)%state( 1:mySizePlasticDotState,c) & - + plasticState(p)%dotState(1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) - enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state (1:mySizePlasticDotState,c) - endif -#endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- UPDATE DEPENDENT STATES --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - - !$OMP PARALLEL - ! --- STRESS INTEGRATION --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- SET CONVERGENCE FLAG --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP END PARALLEL - - - ! --- CHECK NON-LOCAL CONVERGENCE --- - - if (.not. singleRun) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif - -end subroutine integrateStateEuler - - -!-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, state with adaptive 1st order explicit Euler method -!> using Fixed Point Iteration to adapt the stepsize -!-------------------------------------------------------------------------------------------------- -subroutine integrateStateFPI() - use, intrinsic :: & - IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level,& - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif - use numerics, only: & - nState, & - rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_NcpElems - use material, only: & - plasticState, & - sourceState, & - phaseAt, phasememberAt, & - phase_Nsources, & - homogenization_Ngrains - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure, & - constitutive_plasticity_maxSizeDotState, & - constitutive_source_maxSizeDotState - - implicit none - - integer(pInt) :: & - NiterationState, & !< number of iterations in state loop - e, & !< element index in element loop - i, & !< integration point index in ip loop - g, & !< grain index in grain loop - p, & - c, & - mySource, & - mySizePlasticDotState, & ! size of dot states - mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - real(pReal) :: & - dot_prod12, & - dot_prod22, & - plasticStateDamper, & ! damper for integration of state - sourceStateDamper - real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & - plasticStateResiduum, & - tempPlasticState - real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & - sourceStateResiduum, & ! residuum from evolution in micrstructure - tempSourceState - logical :: & - converged, & - NaN, & - singleRun, & ! flag indicating computation for single (g,i,e) triple - doneWithIntegration - - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo at start of state integration' -#endif - -!-------------------------------------------------------------------------------------------------- -! initialize dotState - if (.not. singleRun) then - forall(p = 1_pInt:size(plasticState)) - plasticState(p)%previousDotState = 0.0_pReal - plasticState(p)%previousDotState2 = 0.0_pReal - end forall - do p = 1_pInt, size(sourceState); do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState = 0.0_pReal - sourceState(p)%p(mySource)%previousDotState2 = 0.0_pReal - enddo; enddo - else - e = eIter(1) - i = iIter(1,e) - do g = gIter(1,e), gIter(2,e) - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - plasticState(p)%previousDotState (:,c) = 0.0_pReal - plasticState(p)%previousDotState2(:,c) = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState (:,c) = 0.0_pReal - sourceState(p)%p(mySource)%previousDotState2(:,c) = 0.0_pReal - enddo - enddo - endif - - ! --+>> PREGUESS FOR STATE <<+-- - - ! --- DOT STATES --- - - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,*) '<< CRYST >> dotstate ',plasticState(p)%dotState(:,c) -#endif - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) - !$OMP END CRITICAL (checkTodo) - else ! broken one was local... - crystallite_todo(g,i,e) = .false. ! ... done (and broken) - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- UPDATE STATE --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after preguess of state' -#endif - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state(1:mySizePlasticDotState,c) = & - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - + plasticState(p)%dotState (1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP END PARALLEL - - ! --+>> STATE LOOP <<+-- - - NiterationState = 0_pInt - doneWithIntegration = .false. - crystalliteLooping: do while (.not. doneWithIntegration .and. NiterationState < nState) - NiterationState = NiterationState + 1_pInt - - !$OMP PARALLEL - - ! --- UPDATE DEPENDENT STATES --- - - !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - plasticState(p)%previousDotState2(:,c) = plasticState(p)%previousDotState(:,c) - plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState2(:,c) = sourceState(p)%p(mySource)%previousDotState(:,c) - sourceState(p)%p(mySource)%previousDotState (:,c) = sourceState(p)%p(mySource)%dotState(:,c) - enddo - enddo; enddo; enddo - !$OMP ENDDO - - ! --- STRESS INTEGRATION --- - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo before stress integration' -#endif - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ... then all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after stress integration' -#endif - - ! --- DOT STATE --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - crystallite_todo(g,i,e) = .false. ! ... skip me next time - if (.not. crystallite_localPlasticity(g,i,e)) then ! if me is non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - - endif - - enddo; enddo; enddo - !$OMP ENDDO - - ! --- UPDATE STATE --- - - !$OMP DO PRIVATE(dot_prod12,dot_prod22, & - !$OMP& mySizePlasticDotState,mySizeSourceDotState, & - !$OMP& plasticStateResiduum,sourceStateResiduum, & - !$OMP& plasticStatedamper,sourceStateDamper, & - !$OMP& tempPlasticState,tempSourceState,converged,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - dot_prod12 = dot_product( plasticState(p)%dotState (:,c) & - - plasticState(p)%previousDotState (:,c), & - plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c)) - dot_prod22 = dot_product( plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c), & - plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c)) - if ( dot_prod22 > 0.0_pReal & - .and. ( dot_prod12 < 0.0_pReal & - .or. dot_product(plasticState(p)%dotState(:,c), & - plasticState(p)%previousDotState(:,c)) < 0.0_pReal) ) then - plasticStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) - else - plasticStateDamper = 1.0_pReal - endif - ! --- get residui --- - - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState) = & - plasticState(p)%state(1:mySizePlasticDotState,c) & - - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * plasticStateDamper & - + plasticState(p)%previousDotState(1:mySizePlasticDotState,c) & - * (1.0_pReal - plasticStateDamper)) * crystallite_subdt(g,i,e) - - ! --- correct state with residuum --- - tempPlasticState(1:mySizePlasticDotState) = & - plasticState(p)%state(1:mySizePlasticDotState,c) & - - plasticStateResiduum(1:mySizePlasticDotState) ! need to copy to local variable, since we cant flush a pointer in openmp - - ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) - - plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * plasticStateDamper & - + plasticState(p)%previousDotState(:,c) & - * (1.0_pReal - plasticStateDamper) - - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - dot_prod12 = dot_product( sourceState(p)%p(mySource)%dotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState (:,c), & - sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c)) - dot_prod22 = dot_product( sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c), & - sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c)) - - if ( dot_prod22 > 0.0_pReal & - .and. ( dot_prod12 < 0.0_pReal & - .or. dot_product(sourceState(p)%p(mySource)%dotState(:,c), & - sourceState(p)%p(mySource)%previousDotState(:,c)) < 0.0_pReal) ) then - sourceStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) - else - sourceStateDamper = 1.0_pReal - endif - ! --- get residui --- - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource) = & - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & - - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * sourceStateDamper & - + sourceState(p)%p(mySource)%previousDotState(1:mySizeSourceDotState,c) & - * (1.0_pReal - sourceStateDamper)) * crystallite_subdt(g,i,e) - - ! --- correct state with residuum --- - tempSourceState(1:mySizeSourceDotState,mySource) = & - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & - - sourceStateResiduum(1:mySizeSourceDotState,mySource) ! need to copy to local variable, since we cant flush a pointer in openmp - - ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) - sourceState(p)%p(mySource)%dotState(:,c) = & - sourceState(p)%p(mySource)%dotState(:,c) * sourceStateDamper & - + sourceState(p)%p(mySource)%previousDotState(:,c) & - * (1.0_pReal - sourceStateDamper) - enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g - write(6,'(a,f6.1,/)') '<< CRYST >> plasticstatedamper ',plasticStatedamper - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',& - abs(plasticStateResiduum(1:mySizePlasticDotState)) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> abstol dotstate',plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> reltol dotstate',rTol_crystalliteState* & - abs(tempPlasticState(1:mySizePlasticDotState)) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state',tempPlasticState(1:mySizePlasticDotState) - endif -#endif - - ! --- converged ? --- - converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState) & - .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - converged = converged .and. & - all( abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState) & - .or. abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & - rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,mySource))) - enddo - if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition - - plasticState(p)%state(1:mySizePlasticDotState,c) = & - tempPlasticState(1:mySizePlasticDotState) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & - tempSourceState(1:mySizeSourceDotState,mySource) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. crystallite_converged(g,i,e)) then ! converged and still alive... - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken - crystallite_converged(g,i,e) = .false. - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & - ' grains converged after state integration #', NiterationState -#endif - - ! --- NON-LOCAL CONVERGENCE CHECK --- - - if (.not. singleRun) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) then - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & - ' grains converged after non-local check' - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_todo(:,:,:)), & - ' grains todo after state integration #', NiterationState - endif -#endif - - ! --- CHECK IF DONE WITH INTEGRATION --- - - doneWithIntegration = .true. - elemLoop: do e = eIter(1),eIter(2) - do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - doneWithIntegration = .false. - exit elemLoop - endif - enddo; enddo - enddo elemLoop - - enddo crystalliteLooping -end subroutine integrateStateFPI - - !-------------------------------------------------------------------------------------------------- !> @brief calculates a jump in the state according to the current state and the current stress !> returns true, if state jump was successfull or not needed. false indicates NaN in delta state @@ -3467,4 +1681,1790 @@ function crystallite_postResults(ipc, ip, el) end function crystallite_postResults + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with adaptive 1st order explicit Euler method +!> using Fixed Point Iteration to adapt the stepsize +!-------------------------------------------------------------------------------------------------- +subroutine integrateStateFPI() + use, intrinsic :: & + IEEE_arithmetic +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level,& + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective +#endif + use numerics, only: & + nState, & + rTol_crystalliteState + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_Ngrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState + + implicit none + + integer(pInt) :: & + NiterationState, & !< number of iterations in state loop + e, & !< element index in element loop + i, & !< integration point index in ip loop + g, & !< grain index in grain loop + p, & + c, & + mySource, & + mySizePlasticDotState, & ! size of dot states + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + real(pReal) :: & + dot_prod12, & + dot_prod22, & + plasticStateDamper, & ! damper for integration of state + sourceStateDamper + real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & + plasticStateResiduum, & + tempPlasticState + real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & + sourceStateResiduum, & ! residuum from evolution in micrstructure + tempSourceState + logical :: & + converged, & + NaN, & + singleRun, & ! flag indicating computation for single (g,i,e) triple + doneWithIntegration + + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo at start of state integration' +#endif + +!-------------------------------------------------------------------------------------------------- +! initialize dotState + if (.not. singleRun) then + forall(p = 1_pInt:size(plasticState)) + plasticState(p)%previousDotState = 0.0_pReal + plasticState(p)%previousDotState2 = 0.0_pReal + end forall + do p = 1_pInt, size(sourceState); do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState = 0.0_pReal + sourceState(p)%p(mySource)%previousDotState2 = 0.0_pReal + enddo; enddo + else + e = eIter(1) + i = iIter(1,e) + do g = gIter(1,e), gIter(2,e) + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%previousDotState (:,c) = 0.0_pReal + plasticState(p)%previousDotState2(:,c) = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState (:,c) = 0.0_pReal + sourceState(p)%p(mySource)%previousDotState2(:,c) = 0.0_pReal + enddo + enddo + endif + + ! --+>> PREGUESS FOR STATE <<+-- + + ! --- DOT STATES --- + + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,*) '<< CRYST >> dotstate ',plasticState(p)%dotState(:,c) +#endif + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) + !$OMP END CRITICAL (checkTodo) + else ! broken one was local... + crystallite_todo(g,i,e) = .false. ! ... done (and broken) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- UPDATE STATE --- +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after preguess of state' +#endif + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state(1:mySizePlasticDotState,c) = & + plasticState(p)%subState0(1:mySizePlasticDotState,c) & + + plasticState(p)%dotState (1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP END PARALLEL + + ! --+>> STATE LOOP <<+-- + + NiterationState = 0_pInt + doneWithIntegration = .false. + crystalliteLooping: do while (.not. doneWithIntegration .and. NiterationState < nState) + NiterationState = NiterationState + 1_pInt + + !$OMP PARALLEL + + ! --- UPDATE DEPENDENT STATES --- + + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%previousDotState2(:,c) = plasticState(p)%previousDotState(:,c) + plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState2(:,c) = sourceState(p)%p(mySource)%previousDotState(:,c) + sourceState(p)%p(mySource)%previousDotState (:,c) = sourceState(p)%p(mySource)%dotState(:,c) + enddo + enddo; enddo; enddo + !$OMP ENDDO + + ! --- STRESS INTEGRATION --- + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo before stress integration' +#endif + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ... then all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after stress integration' +#endif + + ! --- DOT STATE --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + crystallite_todo(g,i,e) = .false. ! ... skip me next time + if (.not. crystallite_localPlasticity(g,i,e)) then ! if me is non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + + endif + + enddo; enddo; enddo + !$OMP ENDDO + + ! --- UPDATE STATE --- + + !$OMP DO PRIVATE(dot_prod12,dot_prod22, & + !$OMP& mySizePlasticDotState,mySizeSourceDotState, & + !$OMP& plasticStateResiduum,sourceStateResiduum, & + !$OMP& plasticStatedamper,sourceStateDamper, & + !$OMP& tempPlasticState,tempSourceState,converged,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + dot_prod12 = dot_product( plasticState(p)%dotState (:,c) & + - plasticState(p)%previousDotState (:,c), & + plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c)) + dot_prod22 = dot_product( plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c), & + plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c)) + if ( dot_prod22 > 0.0_pReal & + .and. ( dot_prod12 < 0.0_pReal & + .or. dot_product(plasticState(p)%dotState(:,c), & + plasticState(p)%previousDotState(:,c)) < 0.0_pReal) ) then + plasticStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + else + plasticStateDamper = 1.0_pReal + endif + ! --- get residui --- + + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState) = & + plasticState(p)%state(1:mySizePlasticDotState,c) & + - plasticState(p)%subState0(1:mySizePlasticDotState,c) & + - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * plasticStateDamper & + + plasticState(p)%previousDotState(1:mySizePlasticDotState,c) & + * (1.0_pReal - plasticStateDamper)) * crystallite_subdt(g,i,e) + + ! --- correct state with residuum --- + tempPlasticState(1:mySizePlasticDotState) = & + plasticState(p)%state(1:mySizePlasticDotState,c) & + - plasticStateResiduum(1:mySizePlasticDotState) ! need to copy to local variable, since we cant flush a pointer in openmp + + ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) + + plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * plasticStateDamper & + + plasticState(p)%previousDotState(:,c) & + * (1.0_pReal - plasticStateDamper) + + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + dot_prod12 = dot_product( sourceState(p)%p(mySource)%dotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState (:,c), & + sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c)) + dot_prod22 = dot_product( sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c), & + sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c)) + + if ( dot_prod22 > 0.0_pReal & + .and. ( dot_prod12 < 0.0_pReal & + .or. dot_product(sourceState(p)%p(mySource)%dotState(:,c), & + sourceState(p)%p(mySource)%previousDotState(:,c)) < 0.0_pReal) ) then + sourceStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + else + sourceStateDamper = 1.0_pReal + endif + ! --- get residui --- + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource) = & + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & + - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * sourceStateDamper & + + sourceState(p)%p(mySource)%previousDotState(1:mySizeSourceDotState,c) & + * (1.0_pReal - sourceStateDamper)) * crystallite_subdt(g,i,e) + + ! --- correct state with residuum --- + tempSourceState(1:mySizeSourceDotState,mySource) = & + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & + - sourceStateResiduum(1:mySizeSourceDotState,mySource) ! need to copy to local variable, since we cant flush a pointer in openmp + + ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) + sourceState(p)%p(mySource)%dotState(:,c) = & + sourceState(p)%p(mySource)%dotState(:,c) * sourceStateDamper & + + sourceState(p)%p(mySource)%previousDotState(:,c) & + * (1.0_pReal - sourceStateDamper) + enddo + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g + write(6,'(a,f6.1,/)') '<< CRYST >> plasticstatedamper ',plasticStatedamper + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',& + abs(plasticStateResiduum(1:mySizePlasticDotState)) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> abstol dotstate',plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> reltol dotstate',rTol_crystalliteState* & + abs(tempPlasticState(1:mySizePlasticDotState)) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state',tempPlasticState(1:mySizePlasticDotState) + endif +#endif + + ! --- converged ? --- + converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState) & + .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + converged = converged .and. & + all( abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState) & + .or. abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & + rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,mySource))) + enddo + if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition + + plasticState(p)%state(1:mySizePlasticDotState,c) = & + tempPlasticState(1:mySizePlasticDotState) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & + tempSourceState(1:mySizeSourceDotState,mySource) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. crystallite_converged(g,i,e)) then ! converged and still alive... + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken + crystallite_converged(g,i,e) = .false. + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & + ' grains converged after state integration #', NiterationState +#endif + + ! --- NON-LOCAL CONVERGENCE CHECK --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) then + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & + ' grains converged after non-local check' + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_todo(:,:,:)), & + ' grains todo after state integration #', NiterationState + endif +#endif + + ! --- CHECK IF DONE WITH INTEGRATION --- + + doneWithIntegration = .true. + elemLoop: do e = eIter(1),eIter(2) + do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + doneWithIntegration = .false. + exit elemLoop + endif + enddo; enddo + enddo elemLoop + + enddo crystalliteLooping + +end subroutine integrateStateFPI + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, and state with 1st order explicit Euler method +!-------------------------------------------------------------------------------------------------- +subroutine integrateStateEuler() + use, intrinsic :: & + IEEE_arithmetic +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective +#endif + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_Ngrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure + + implicit none + + integer(pInt) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + p, & ! phase loop + c, & + mySource, & + mySizePlasticDotState, & + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + logical :: & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + +eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + !$OMP PARALLEL + + ! --- DOT STATE --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + c = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE STATE --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state( 1:mySizePlasticDotState,c) = & + plasticState(p)%state( 1:mySizePlasticDotState,c) & + + plasticState(p)%dotState(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state (1:mySizePlasticDotState,c) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE DEPENDENT STATES --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + + !$OMP PARALLEL + ! --- STRESS INTEGRATION --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- SET CONVERGENCE FLAG --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP END PARALLEL + + + ! --- CHECK NON-LOCAL CONVERGENCE --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + +end subroutine integrateStateEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 1st order Euler method with adaptive step size +!-------------------------------------------------------------------------------------------------- +subroutine integrateStateAdaptiveEuler() + use, intrinsic :: & + IEEE_arithmetic +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective +#endif + use numerics, only: & + rTol_crystalliteState + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_maxNgrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState + + implicit none + integer(pInt) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + s, & ! state index + p, & + c, & + mySource, & + mySizePlasticDotState, & ! size of dot states + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + plasticStateResiduum, & ! residuum from evolution in micrstructure + relPlasticStateResiduum ! relative residuum from evolution in microstructure + real(pReal), dimension(constitutive_source_maxSizeDotState,& + maxval(phase_Nsources), & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + sourceStateResiduum, & ! residuum from evolution in micrstructure + relSourceStateResiduum ! relative residuum from evolution in microstructure + + logical :: & + converged, & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + + ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + + plasticStateResiduum = 0.0_pReal + relPlasticStateResiduum = 0.0_pReal + sourceStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + + + !$OMP PARALLEL + ! --- DOT STATE (EULER INTEGRATION) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE UPDATE (EULER INTEGRATION) --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + - 0.5_pReal & + * plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + plasticState(p)%state (1:mySizePlasticDotState,c) = & + plasticState(p)%state (1:mySizePlasticDotState,c) & + + plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + - 0.5_pReal & + * sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE DEPENDENT STATES (EULER INTEGRATION) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + + ! --- STRESS INTEGRATION (EULER INTEGRATION) --- + + !$OMP PARALLEL DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + + !$OMP PARALLEL + ! --- DOT STATE (HEUN METHOD) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- ERROR ESTIMATE FOR STATE (HEUN METHOD) --- + + !$OMP SINGLE + relPlasticStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + !$OMP END SINGLE + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + ! --- contribution of heun step to absolute residui --- + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) & + + 0.5_pReal * plasticState(p)%dotState(:,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) & + + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + enddo + + ! --- relative residui --- + forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & + relPlasticStateResiduum(s,g,i,e) = & + plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & + relSourceStateResiduum(s,mySource,g,i,e) = & + sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) + enddo + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & + relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) & + - 2.0_pReal * plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / crystallite_subdt(g,i,e) ! calculate former dotstate from higher order solution and state residuum + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) + endif +#endif + + ! --- converged ? --- + converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + converged = converged .and. & + all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + rTol_crystalliteState .or. & + abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + enddo + if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definitionem + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + + ! --- NONLOCAL CONVERGENCE CHECK --- +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' +#endif + if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + + +end subroutine integrateStateAdaptiveEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 4th order explicit Runge Kutta method +!-------------------------------------------------------------------------------------------------- +subroutine integrateStateRK4() + use, intrinsic :: & + IEEE_arithmetic +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective +#endif + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + use config, only: & + material_Nphase + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure + + implicit none + real(pReal), dimension(4), parameter :: & + TIMESTEPFRACTION = [0.5_pReal, 0.5_pReal, 1.0_pReal, 1.0_pReal] ! factor giving the fraction of the original timestep used for Runge Kutta Integration + 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 + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + p, & ! phase loop + c, & + n, & + mySource, & + mySizePlasticDotState, & + mySizeSourceDotState + integer(pInt), dimension(2) :: eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + logical :: NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + +!-------------------------------------------------------------------------------------------------- +! initialize dotState + if (.not. singleRun) then + do p = 1_pInt, material_Nphase + plasticState(p)%RK4dotState = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RK4dotState = 0.0_pReal + enddo + enddo + else + e = eIter(1) + i = iIter(1,e) + do g = gIter(1,e), gIter(2,e) + plasticState(phaseAt(g,i,e))%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + sourceState(phaseAt(g,i,e))%p(mySource)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal + enddo + enddo + endif + +!-------------------------------------------------------------------------------------------------- +! first Runge-Kutta step + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + c = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL +!-------------------------------------------------------------------------------------------------- +! --- SECOND TO FOURTH RUNGE KUTTA STEP PLUS FINAL INTEGRATION --- + + do n = 1_pInt,4_pInt + ! --- state update --- + + !$OMP PARALLEL + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%RK4dotState(:,c) = plasticState(p)%RK4dotState(:,c) & + + weight(n)*plasticState(p)%dotState(:,c) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RK4dotState(:,c) = sourceState(p)%p(mySource)%RK4dotState(:,c) & + + weight(n)*sourceState(p)%p(mySource)%dotState(:,c) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state (1:mySizePlasticDotState,c) = & + plasticState(p)%subState0(1:mySizePlasticDotState,c) & + + plasticState(p)%dotState (1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) * timeStepFraction(n) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) * timeStepFraction(n) + enddo + +#ifdef DEBUG + if (n == 4 & + .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then ! final integration step + + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- state jump --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- update dependent states --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- stress integration --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e,timeStepFraction(n)) ! fraction of original times step + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- dot state and RK dot state--- + + first3steps: if (n < 4) then + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + timeStepFraction(n)*crystallite_subdt(g,i,e), & ! fraction of original timestep + crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + endif first3steps + !$OMP END PARALLEL + + enddo + + + ! --- SET CONVERGENCE FLAG --- + + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem + enddo; enddo; enddo + + + ! --- CHECK NONLOCAL CONVERGENCE --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) then ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + endif + +end subroutine integrateStateRK4 + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 5th order Runge-Kutta Cash-Karp method with +!> adaptive step size (use 5th order solution to advance = "local extrapolation") +!-------------------------------------------------------------------------------------------------- +subroutine integrateStateRKCK45() + use, intrinsic :: & + IEEE_arithmetic +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective +#endif + use numerics, only: & + rTol_crystalliteState + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt, & + homogenization_maxNgrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState, & + constitutive_microstructure + + implicit none + real(pReal), dimension(5,5), parameter :: & + A = reshape([& + .2_pReal, .075_pReal, .3_pReal, -11.0_pReal/54.0_pReal, 1631.0_pReal/55296.0_pReal, & + .0_pReal, .225_pReal, -.9_pReal, 2.5_pReal, 175.0_pReal/512.0_pReal, & + .0_pReal, .0_pReal, 1.2_pReal, -70.0_pReal/27.0_pReal, 575.0_pReal/13824.0_pReal, & + .0_pReal, .0_pReal, .0_pReal, 35.0_pReal/27.0_pReal, 44275.0_pReal/110592.0_pReal, & + .0_pReal, .0_pReal, .0_pReal, .0_pReal, 253.0_pReal/4096.0_pReal], & + [5,5], order=[2,1]) !< coefficients in Butcher tableau (used for preliminary integration in stages 2 to 6) + + real(pReal), dimension(6), parameter :: & + B = & + [37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, & + 125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], & !< coefficients in Butcher tableau (used for final integration and error estimate) + DB = B - & + [2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,& + 13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 0.25_pReal] !< coefficients in Butcher tableau (used for final integration and error estimate) + + 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) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + stage, & ! stage index in integration stage loop + s, & ! state index + n, & + p, & + cc, & + mySource, & + mySizePlasticDotState, & ! size of dot States + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + plasticStateResiduum, & ! residuum from evolution in microstructure + relPlasticStateResiduum ! relative residuum from evolution in microstructure + real(pReal), dimension(constitutive_source_maxSizeDotState, & + maxval(phase_Nsources), & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + sourceStateResiduum, & ! residuum from evolution in microstructure + relSourceStateResiduum ! relative residuum from evolution in microstructure + logical :: & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + eIter = FEsolving_execElem(1:2) +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',1 +#endif + + ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + + + ! --- FIRST RUNGE KUTTA STEP --- + + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,cc,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + cc = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + + ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- + + do stage = 1_pInt,5_pInt + + ! --- state update --- + + !$OMP PARALLEL + !$OMP DO PRIVATE(p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) ! store Runge-Kutta dotState + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,cc,n) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + + plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(mySource)%RKCK45dotState(1,:,cc) + enddo + do n = 2_pInt, stage + plasticState(p)%dotState(:,cc) = & + plasticState(p)%dotState(:,cc) + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%dotState(:,cc) = & + sourceState(p)%p(mySource)%dotState(:,cc) + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) + enddo + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState (p)%state (1:mySizePlasticDotState, cc) = & + plasticState (p)%subState0(1:mySizePlasticDotState, cc) & + + plasticState (p)%dotState (1:mySizePlasticDotState, cc) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- state jump --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- update dependent states --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- stress integration --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e,C(stage)) ! fraction of original time step + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- dot state and RK dot state--- +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',stage+1_pInt +#endif + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + C(stage)*crystallite_subdt(g,i,e), & ! fraction of original timestep + crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,cc,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + enddo + + +!-------------------------------------------------------------------------------------------------- +! --- STATE UPDATE WITH ERROR ESTIMATE FOR STATE --- + + relPlasticStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + !$OMP PARALLEL + !$OMP DO PRIVATE(p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) ! store Runge-Kutta dotState + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + + ! --- absolute residuum in state --- + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)),DB) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & + * crystallite_subdt(g,i,e) + enddo + + ! --- dot state --- + plasticState(p)%dotState(:,cc) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%dotState(:,cc) = & + matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- state and update --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state (1:mySizePlasticDotState,cc) = & + plasticState(p)%subState0(1:mySizePlasticDotState,cc) & + + plasticState(p)%dotState (1:mySizePlasticDotState,cc) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc)& + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- relative residui and state convergence --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(s,cc)) > 0.0_pReal) & + relPlasticStateResiduum(s,g,i,e) = & + plasticStateResiduum(s,g,i,e) / plasticState(p)%state(s,cc) + + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(s,cc)) > 0.0_pReal) & + relSourceStateResiduum(s,mySource,g,i,e) = & + sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%state(s,cc) + enddo + crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & + all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + rTol_crystalliteState .or. & + abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + enddo + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt& + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i3,1x,i3,/)') '<< CRYST >> updateState at el ip ipc ',e,i,g + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & + relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', & + plasticState(p)%dotState(1:mySizePlasticDotState,cc) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & + plasticState(p)%state(1:mySizePlasticDotState,cc) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- UPDATE DEPENDENT STATES IF RESIDUUM BELOW TOLERANCE --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- FINAL STRESS INTEGRATION STEP IF RESIDUUM BELOW TOLERANCE --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- SET CONVERGENCE FLAG --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + 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 ENDDO + + !$OMP END PARALLEL + + + ! --- nonlocal convergence check --- +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' ! if not requesting Integration of just a single IP +#endif + if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + +end subroutine integrateStateRKCK45 + end module crystallite From efb07e0b93c83e3c0e2afacf8d32fad4c76ba5b6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 15 Jan 2019 04:55:40 +0100 Subject: [PATCH 224/372] only output direct quantities derived quantities can be easily calculated during post processing --- src/plastic_nonlocal.f90 | 573 +-------------------------------------- 1 file changed, 4 insertions(+), 569 deletions(-) diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index e1355da8f..a7288bde0 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -150,61 +150,34 @@ module plastic_nonlocal enum, bind(c) enumerator :: undefined_ID, & - rho_ID, & - delta_ID, & - rho_edge_ID, & - rho_screw_ID, & - rho_sgl_ID, & - delta_sgl_ID, & - rho_sgl_edge_ID, & - rho_sgl_edge_pos_ID, & - rho_sgl_edge_neg_ID, & - rho_sgl_screw_ID, & - rho_sgl_screw_pos_ID, & - rho_sgl_screw_neg_ID, & - rho_sgl_mobile_ID, & - rho_sgl_edge_mobile_ID, & rho_sgl_edge_pos_mobile_ID, & rho_sgl_edge_neg_mobile_ID, & - rho_sgl_screw_mobile_ID, & rho_sgl_screw_pos_mobile_ID, & rho_sgl_screw_neg_mobile_ID, & - rho_sgl_immobile_ID, & - rho_sgl_edge_immobile_ID, & rho_sgl_edge_pos_immobile_ID, & rho_sgl_edge_neg_immobile_ID, & - rho_sgl_screw_immobile_ID, & rho_sgl_screw_pos_immobile_ID, & rho_sgl_screw_neg_immobile_ID, & - rho_dip_ID, & - delta_dip_ID, & rho_dip_edge_ID, & rho_dip_screw_ID, & - excess_rho_ID, & - excess_rho_edge_ID, & - excess_rho_screw_ID, & rho_forest_ID, & shearrate_ID, & resolvedstress_ID, & resolvedstress_external_ID, & resolvedstress_back_ID, & resistance_ID, & - rho_dot_ID, & rho_dot_sgl_ID, & rho_dot_sgl_mobile_ID, & rho_dot_dip_ID, & rho_dot_gen_ID, & rho_dot_gen_edge_ID, & rho_dot_gen_screw_ID, & - rho_dot_sgl2dip_ID, & rho_dot_sgl2dip_edge_ID, & rho_dot_sgl2dip_screw_ID, & rho_dot_ann_ath_ID, & - rho_dot_ann_the_ID, & rho_dot_ann_the_edge_ID, & rho_dot_ann_the_screw_ID, & rho_dot_edgejogs_ID, & - rho_dot_flux_ID, & rho_dot_flux_mobile_ID, & rho_dot_flux_edge_ID, & rho_dot_flux_screw_ID, & @@ -212,28 +185,9 @@ module plastic_nonlocal velocity_edge_neg_ID, & velocity_screw_pos_ID, & velocity_screw_neg_ID, & - slipdirectionx_ID, & - slipdirectiony_ID, & - slipdirectionz_ID, & - slipnormalx_ID, & - slipnormaly_ID, & - slipnormalz_ID, & - fluxdensity_edge_posx_ID, & - fluxdensity_edge_posy_ID, & - fluxdensity_edge_posz_ID, & - fluxdensity_edge_negx_ID, & - fluxdensity_edge_negy_ID, & - fluxdensity_edge_negz_ID, & - fluxdensity_screw_posx_ID, & - fluxdensity_screw_posy_ID, & - fluxdensity_screw_posz_ID, & - fluxdensity_screw_negx_ID, & - fluxdensity_screw_negy_ID, & - fluxdensity_screw_negz_ID, & maximumdipoleheight_edge_ID, & maximumdipoleheight_screw_ID, & - accumulatedshear_ID, & - dislocationstress_ID + accumulatedshear_ID end enum integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & plastic_nonlocal_outputID !< ID of each post result output @@ -426,76 +380,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s select case(tag) case ('(output)') select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('rho') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta_sgl') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_sgl_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_pos') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_neg') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_pos') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_neg') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_edge_pos_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_mobile_ID @@ -506,11 +390,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_mobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_screw_pos_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_mobile_ID @@ -521,31 +400,11 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_mobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_edge_pos_immobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_immobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_neg_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_screw_pos_immobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_immobile_ID @@ -556,16 +415,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_immobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta_dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dip_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_edge_ID @@ -576,21 +425,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_screw_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_forest') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_forest_ID @@ -621,11 +455,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resistance_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_sgl') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl_ID @@ -656,11 +485,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_gen_screw_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_sgl2dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_sgl2dip_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_edge_ID @@ -676,11 +500,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_ath_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_ann_the') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_ann_the_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_edge_ID @@ -696,11 +515,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_edgejogs_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_flux') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_flux_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_mobile_ID @@ -736,96 +550,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_screw_neg_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectiony_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormaly_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('maximumdipoleheight_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = maximumdipoleheight_edge_ID @@ -841,11 +565,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = accumulatedshear_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('dislocationstress') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = dislocationstress_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) end select case ('nslip') if (chunkPos(1) < 1_pInt + Nchunks_SlipFamilies) & @@ -1195,93 +914,8 @@ allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) select case(plastic_nonlocal_outputID(o,instance)) - case( rho_ID, & - delta_ID, & - rho_edge_ID, & - rho_screw_ID, & - rho_sgl_ID, & - delta_sgl_ID, & - rho_sgl_edge_ID, & - rho_sgl_edge_pos_ID, & - rho_sgl_edge_neg_ID, & - rho_sgl_screw_ID, & - rho_sgl_screw_pos_ID, & - rho_sgl_screw_neg_ID, & - rho_sgl_mobile_ID, & - rho_sgl_edge_mobile_ID, & - rho_sgl_edge_pos_mobile_ID, & - rho_sgl_edge_neg_mobile_ID, & - rho_sgl_screw_mobile_ID, & - rho_sgl_screw_pos_mobile_ID, & - rho_sgl_screw_neg_mobile_ID, & - rho_sgl_immobile_ID, & - rho_sgl_edge_immobile_ID, & - rho_sgl_edge_pos_immobile_ID, & - rho_sgl_edge_neg_immobile_ID, & - rho_sgl_screw_immobile_ID, & - rho_sgl_screw_pos_immobile_ID, & - rho_sgl_screw_neg_immobile_ID, & - rho_dip_ID, & - delta_dip_ID, & - rho_dip_edge_ID, & - rho_dip_screw_ID, & - excess_rho_ID, & - excess_rho_edge_ID, & - excess_rho_screw_ID, & - rho_forest_ID, & - shearrate_ID, & - resolvedstress_ID, & - resolvedstress_external_ID, & - resolvedstress_back_ID, & - resistance_ID, & - rho_dot_ID, & - rho_dot_sgl_ID, & - rho_dot_sgl_mobile_ID, & - rho_dot_dip_ID, & - rho_dot_gen_ID, & - rho_dot_gen_edge_ID, & - rho_dot_gen_screw_ID, & - rho_dot_sgl2dip_ID, & - rho_dot_sgl2dip_edge_ID, & - rho_dot_sgl2dip_screw_ID, & - rho_dot_ann_ath_ID, & - rho_dot_ann_the_ID, & - rho_dot_ann_the_edge_ID, & - rho_dot_ann_the_screw_ID, & - rho_dot_edgejogs_ID, & - rho_dot_flux_ID, & - rho_dot_flux_mobile_ID, & - rho_dot_flux_edge_ID, & - rho_dot_flux_screw_ID, & - velocity_edge_pos_ID, & - velocity_edge_neg_ID, & - velocity_screw_pos_ID, & - velocity_screw_neg_ID, & - slipdirectionx_ID, & - slipdirectiony_ID, & - slipdirectionz_ID, & - slipnormalx_ID, & - slipnormaly_ID, & - slipnormalz_ID, & - fluxdensity_edge_posx_ID, & - fluxdensity_edge_posy_ID, & - fluxdensity_edge_posz_ID, & - fluxdensity_edge_negx_ID, & - fluxdensity_edge_negy_ID, & - fluxdensity_edge_negz_ID, & - fluxdensity_screw_posx_ID, & - fluxdensity_screw_posy_ID, & - fluxdensity_screw_posz_ID, & - fluxdensity_screw_negx_ID, & - fluxdensity_screw_negy_ID, & - fluxdensity_screw_negz_ID, & - maximumdipoleheight_edge_ID, & - maximumdipoleheight_screw_ID, & - accumulatedshear_ID ) - mySize = totalNslip(instance) - case(dislocationstress_ID) - mySize = 6_pInt case default + mySize = totalNslip(instance) end select if (mySize > 0_pInt) then ! any meaningful output found @@ -3655,45 +3289,6 @@ forall (s = 1_pInt:ns) & outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) select case(plastic_nonlocal_outputID(o,instance)) - case (rho_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) + sum(rhoDip,2) - cs = cs + ns - - case (rho_sgl_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) - cs = cs + ns - - case (rho_sgl_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,1:4)),2) - cs = cs + ns - - case (rho_sgl_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:8),2) - cs = cs + ns - - case (rho_dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDip,2) - cs = cs + ns - - case (rho_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) + rhoDip(1:ns,1) - cs = cs + ns - - case (rho_sgl_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) - cs = cs + ns - - case (rho_sgl_edge_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,1:2),2) - cs = cs + ns - - case (rho_sgl_edge_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:6),2) - cs = cs + ns - - case (rho_sgl_edge_pos_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5)) - cs = cs + ns case (rho_sgl_edge_pos_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) @@ -3703,10 +3298,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,5) cs = cs + ns - case (rho_sgl_edge_neg_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6)) - cs = cs + ns - case (rho_sgl_edge_neg_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) cs = cs + ns @@ -3719,26 +3310,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,1) cs = cs + ns - case (rho_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) + rhoDip(1:ns,2) - cs = cs + ns - - case (rho_sgl_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) - cs = cs + ns - - case (rho_sgl_screw_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,3:4),2) - cs = cs + ns - - case (rho_sgl_screw_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,7:8),2) - cs = cs + ns - - case (rho_sgl_screw_pos_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7)) - cs = cs + ns - case (rho_sgl_screw_pos_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) cs = cs + ns @@ -3746,10 +3317,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (rho_sgl_screw_pos_immobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,7) cs = cs + ns - - case (rho_sgl_screw_neg_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8)) - cs = cs + ns case (rho_sgl_screw_neg_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) @@ -3763,38 +3330,9 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,2) cs = cs + ns - case (excess_rho_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & - - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) & - + (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & - - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) - cs = cs + ns - - case (excess_rho_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & - - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) - cs = cs + ns - - case (excess_rho_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & - - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) - cs = cs + ns - case (rho_forest_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoForest cs = cs + ns - - case (delta_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2) + sum(rhoDip,2)) - cs = cs + ns - - case (delta_sgl_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2)) - cs = cs + ns - - case (delta_dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(rhoDip,2)) - cs = cs + ns case (shearrate_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(gdot,2) @@ -3818,12 +3356,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (resistance_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = tauThreshold cs = cs + ns - - case (rho_dot_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & - + sum(rhoDotSgl(1:ns,5:8)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) & - + sum(rhoDotDip,2) - cs = cs + ns case (rho_dot_sgl_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & @@ -3838,7 +3370,7 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotDip,2) cs = cs + ns - case (rho_dot_gen_ID) + case (rho_dot_gen_ID) ! Obsolete plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,1,1_pInt,ip,el) & + rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns @@ -3850,11 +3382,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (rho_dot_gen_screw_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns - - case (rho_dot_sgl2dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) & - + rhoDotSingle2DipoleGlideOutput(1:ns,2,1_pInt,ip,el) - cs = cs + ns case (rho_dot_sgl2dip_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) @@ -3868,11 +3395,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotAthermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & + rhoDotAthermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns - - case (rho_dot_ann_the_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & - + rhoDotThermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) - cs = cs + ns case (rho_dot_ann_the_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) @@ -3890,11 +3412,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) cs = cs + ns - case (rho_dot_flux_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) & - + sum(rhoDotFluxOutput(1:ns,5:8,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) - cs = cs + ns - case (rho_dot_flux_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:2,1_pInt,ip,el),2) & + sum(rhoDotFluxOutput(1:ns,5:6,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:6)),2) @@ -3921,78 +3438,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,4) cs = cs + ns - case (slipdirectionx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(1,1:ns,1) - cs = cs + ns - - case (slipdirectiony_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(2,1:ns,1) - cs = cs + ns - - case (slipdirectionz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(3,1:ns,1) - cs = cs + ns - - case (slipnormalx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(1,1:ns) - cs = cs + ns - - case (slipnormaly_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(2,1:ns) - cs = cs + ns - - case (slipnormalz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(3,1:ns) - cs = cs + ns - - case (fluxdensity_edge_posx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(1,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_posy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(2,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_posz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(3,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(1,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(2,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(3,1:ns,1) - cs = cs + ns - - case (fluxdensity_screw_posx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(1,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_posy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(2,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_posz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(3,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(1,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(2,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(3,1:ns,2) - cs = cs + ns - case (maximumdipoleheight_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,1) cs = cs + ns @@ -4000,17 +3445,7 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (maximumdipoleheight_screw_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,2) cs = cs + ns - - case(dislocationstress_ID) - sigma = plastic_nonlocal_dislocationstress(Fe, ip, el) - plastic_nonlocal_postResults(cs+1_pInt) = sigma(1,1) - plastic_nonlocal_postResults(cs+2_pInt) = sigma(2,2) - plastic_nonlocal_postResults(cs+3_pInt) = sigma(3,3) - plastic_nonlocal_postResults(cs+4_pInt) = sigma(1,2) - plastic_nonlocal_postResults(cs+5_pInt) = sigma(2,3) - plastic_nonlocal_postResults(cs+6_pInt) = sigma(3,1) - cs = cs + 6_pInt - + case(accumulatedshear_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = plasticState(ph)%state(iGamma(1:ns,instance),of) cs = cs + ns From 80dca6d30436b526f92873f75027506cf83607c9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 15 Jan 2019 07:52:01 +0100 Subject: [PATCH 225/372] also not needed was a remainder from time syncinc --- src/crystallite.f90 | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 7c8b02863..4750b43c7 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -73,14 +73,10 @@ module crystallite logical, dimension(:,:,:), allocatable, public :: & crystallite_requested !< flag to request crystallite calculation logical, dimension(:,:,:), allocatable, public, protected :: & - crystallite_converged, & !< convergence flag - crystallite_localPlasticity !< indicates this grain to have purely local constitutive law + crystallite_converged !< convergence flag logical, dimension(:,:,:), allocatable, private :: & + crystallite_localPlasticity, & !< indicates this grain to have purely local constitutive law crystallite_todo !< flag to indicate need for further computation - logical, dimension(:,:), allocatable, private :: & - crystallite_clearToWindForward, & !< description not available - crystallite_clearToCutback, & !< description not available - crystallite_neighborEnforcedCutback !< description not available enum, bind(c) enumerator :: undefined_ID, & @@ -245,9 +241,6 @@ subroutine crystallite_init 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_clearToWindForward(iMax,eMax), source=.true.) - allocate(crystallite_clearToCutback(iMax,eMax), source=.true.) - allocate(crystallite_neighborEnforcedCutback(iMax,eMax), source=.false.) allocate(crystallite_output(maxval(crystallite_Noutput), & size(config_crystallite))) ; crystallite_output = '' allocate(crystallite_outputID(maxval(crystallite_Noutput), & @@ -601,7 +594,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) do c = 1,homogenization_Ngrains(mesh_element(3,e)) ! --- wind forward --- - if (crystallite_converged(c,i,e) .and. crystallite_clearToWindForward(i,e)) then + 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), & @@ -636,7 +629,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) ! --- cutback --- - elseif (.not. crystallite_converged(c,i,e) .and. crystallite_clearToCutback(i,e)) then + elseif (.not. crystallite_converged(c,i,e)) then crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) ! cut step in half and restore... crystallite_Fp(1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) ! ...plastic def grad crystallite_invFp(1:3,1:3,c,i,e) = math_inv33(crystallite_Fp(1:3,1:3,c,i,e)) @@ -672,7 +665,7 @@ subroutine crystallite_stressAndItsTangent(updateJaco) ! --- prepare for integration --- - if (crystallite_todo(c,i,e) .and. (crystallite_clearToWindForward(i,e) .or. crystallite_clearToCutback(i,e))) then + 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)) From 6049e292c110660e3a5a2ca056c0593840132761 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 15 Jan 2019 08:04:50 +0100 Subject: [PATCH 226/372] no need to store converged tangent --- src/CPFEM.f90 | 10 ---------- src/CPFEM2.f90 | 5 ----- src/crystallite.f90 | 7 +------ src/homogenization.f90 | 8 -------- 4 files changed, 1 insertion(+), 29 deletions(-) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 847688d57..12567f000 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -155,7 +155,6 @@ subroutine CPFEM_init crystallite_Lp0, & crystallite_Fi0, & crystallite_Li0, & - crystallite_dPdF0, & crystallite_Tstar0_v implicit none @@ -207,9 +206,6 @@ subroutine CPFEM_init read (777,rec=1) crystallite_Li0 close (777) - call IO_read_realFile(777,'convergeddPdF'//trim(rankStr),modelName,size(crystallite_dPdF0)) - read (777,rec=1) crystallite_dPdF0 - close (777) call IO_read_realFile(777,'convergedTstar'//trim(rankStr),modelName,size(crystallite_Tstar0_v)) read (777,rec=1) crystallite_Tstar0_v @@ -326,7 +322,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt crystallite_Lp, & crystallite_Li0, & crystallite_Li, & - crystallite_dPdF0, & crystallite_dPdF, & crystallite_Tstar0_v, & crystallite_Tstar_v @@ -398,7 +393,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt crystallite_Lp0 = crystallite_Lp ! crystallite plastic velocity crystallite_Fi0 = crystallite_Fi ! crystallite intermediate deformation crystallite_Li0 = crystallite_Li ! crystallite intermediate velocity - crystallite_dPdF0 = crystallite_dPdF ! crystallite stiffness crystallite_Tstar0_v = crystallite_Tstar_v ! crystallite 2nd Piola Kirchhoff stress forall ( i = 1:size(plasticState )) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lenghty way because: A component cannot be an array if the encompassing structure is an array @@ -454,10 +448,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt write (777,rec=1) crystallite_Li0 close (777) - call IO_write_jobRealFile(777,'convergeddPdF'//trim(rankStr),size(crystallite_dPdF0)) - write (777,rec=1) crystallite_dPdF0 - close (777) - call IO_write_jobRealFile(777,'convergedTstar'//trim(rankStr),size(crystallite_Tstar0_v)) write (777,rec=1) crystallite_Tstar0_v close (777) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 75f57f4c2..91cc08296 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -121,7 +121,6 @@ subroutine CPFEM_init crystallite_Lp0, & crystallite_Fi0, & crystallite_Li0, & - crystallite_dPdF0, & crystallite_Tstar0_v use hdf5 use HDF5_utilities, only: & @@ -160,7 +159,6 @@ subroutine CPFEM_init call HDF5_read(fileHandle,crystallite_Fi0, 'convergedFi') call HDF5_read(fileHandle,crystallite_Lp0, 'convergedLp') call HDF5_read(fileHandle,crystallite_Li0, 'convergedLi') - call HDF5_read(fileHandle,crystallite_dPdF0, 'convergeddPdF') call HDF5_read(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') @@ -224,7 +222,6 @@ subroutine CPFEM_age() crystallite_Lp, & crystallite_Li0, & crystallite_Li, & - crystallite_dPdF0, & crystallite_dPdF, & crystallite_Tstar0_v, & crystallite_Tstar_v @@ -254,7 +251,6 @@ subroutine CPFEM_age() crystallite_Lp0 = crystallite_Lp crystallite_Fi0 = crystallite_Fi crystallite_Li0 = crystallite_Li - crystallite_dPdF0 = crystallite_dPdF crystallite_Tstar0_v = crystallite_Tstar_v forall (i = 1:size(plasticState)) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lengthy way because: A component cannot be an array if the encompassing structure is an array @@ -283,7 +279,6 @@ subroutine CPFEM_age() call HDF5_write(fileHandle,crystallite_Fi0, 'convergedFi') call HDF5_write(fileHandle,crystallite_Lp0, 'convergedLp') call HDF5_write(fileHandle,crystallite_Li0, 'convergedLi') - call HDF5_write(fileHandle,crystallite_dPdF0, 'convergeddPdF') call HDF5_write(fileHandle,crystallite_Tstar0_v,'convergedTstar') groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 4750b43c7..5377052e2 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -67,9 +67,7 @@ module crystallite 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) - crystallite_dPdF0, & !< individual dPdF per grain at start of FE inc - crystallite_partioneddPdF0 !< individual dPdF per grain at start of homog inc + crystallite_dPdF !< current individual dPdF per grain (end of converged time step) logical, dimension(:,:,:), allocatable, public :: & crystallite_requested !< flag to request crystallite calculation logical, dimension(:,:,:), allocatable, public, protected :: & @@ -228,8 +226,6 @@ subroutine crystallite_init 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_dPdF0(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partioneddPdF0(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) @@ -560,7 +556,6 @@ subroutine crystallite_stressAndItsTangent(updateJaco) crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e) ! ...plastic velocity grad crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e) ! ...intermediate def grad crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e) ! ...intermediate velocity grad - crystallite_dPdF0(1:3,1:3,1:3,1:3,c,i,e) = crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,c,i,e) ! ...stiffness crystallite_subF0(1:3,1:3,c,i,e) = crystallite_partionedF0(1:3,1:3,c,i,e) ! ...def grad crystallite_subTstar0_v(1:6,c,i,e) = crystallite_partionedTstar0_v(1:6,c,i,e) !...2nd PK stress crystallite_subFrac(c,i,e) = 0.0_pReal diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 4663caa9d..4f9b1c19c 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -352,7 +352,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_Li0, & crystallite_Li, & crystallite_dPdF, & - crystallite_dPdF0, & crystallite_Tstar0_v, & crystallite_Tstar_v, & crystallite_partionedF0, & @@ -361,7 +360,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_partionedLp0, & crystallite_partionedFi0, & crystallite_partionedLi0, & - crystallite_partioneddPdF0, & crystallite_partionedTstar0_v, & crystallite_dt, & crystallite_requested, & @@ -419,7 +417,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_partionedLp0(1:3,1:3,g,i,e) = crystallite_Lp0(1:3,1:3,g,i,e) ! ...plastic velocity grads crystallite_partionedFi0(1:3,1:3,g,i,e) = crystallite_Fi0(1:3,1:3,g,i,e) ! ...intermediate def grads crystallite_partionedLi0(1:3,1:3,g,i,e) = crystallite_Li0(1:3,1:3,g,i,e) ! ...intermediate velocity grads - crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,g,i,e) = crystallite_dPdF0(1:3,1:3,1:3,1:3,g,i,e) ! ...stiffness crystallite_partionedF0(1:3,1:3,g,i,e) = crystallite_F0(1:3,1:3,g,i,e) ! ...def grads crystallite_partionedTstar0_v(1:6,g,i,e) = crystallite_Tstar0_v(1:6,g,i,e) ! ...2nd PK stress @@ -489,9 +486,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_partionedLi0(1:3,1:3,1:myNgrains,i,e) = & crystallite_Li(1:3,1:3,1:myNgrains,i,e) ! ...intermediate velocity grads - crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,1:myNgrains,i,e) = & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:myNgrains,i,e) ! ...stiffness - crystallite_partionedTstar0_v(1:6,1:myNgrains,i,e) = & crystallite_Tstar_v(1:6,1:myNgrains,i,e) ! ...2nd PK stress @@ -555,8 +549,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_partionedFi0(1:3,1:3,1:myNgrains,i,e) ! ...intermediate def grads crystallite_Li(1:3,1:3,1:myNgrains,i,e) = & crystallite_partionedLi0(1:3,1:3,1:myNgrains,i,e) ! ...intermediate velocity grads - crystallite_dPdF(1:3,1:3,1:3,1:3,1:myNgrains,i,e) = & - crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,1:myNgrains,i,e) ! ...stiffness crystallite_Tstar_v(1:6,1:myNgrains,i,e) = & crystallite_partionedTstar0_v(1:6,1:myNgrains,i,e) ! ...2nd PK stress do g = 1, myNgrains From 854afb7107612ae75c3ef312b8825839374dc140 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 15 Jan 2019 15:54:05 +0100 Subject: [PATCH 227/372] removed on output too much --- src/plastic_nonlocal.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index a7288bde0..c43de6627 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -405,6 +405,11 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_immobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_neg_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_screw_pos_immobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_immobile_ID From f2cabc5ce5e8ddf4020edf5db343a6432a99a97e Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 16 Jan 2019 00:21:49 +0100 Subject: [PATCH 228/372] [skip ci] updated version information after successful test of v2.0.2-1412-gc231c808 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index d587bea54..acfbef163 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1404-g3f40eeac +v2.0.2-1412-gc231c808 From 2b77e397c13bd1413edf8c292e63c02d96dab148 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 16 Jan 2019 12:33:53 +0100 Subject: [PATCH 229/372] [skip ci] updated version information after successful test of v2.0.2-1417-gc39b642a --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index acfbef163..0ef928226 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1412-gc231c808 +v2.0.2-1417-gc39b642a From da115ca9d43081e078a0ed535957bb016034079c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 16 Jan 2019 17:51:37 +0100 Subject: [PATCH 230/372] probably never used and outdated (python2.7) doing the same conversion via DREAM.3D will be available soon --- processing/pre/geom_fromVPSC.py | 185 -------------------------------- 1 file changed, 185 deletions(-) delete mode 100755 processing/pre/geom_fromVPSC.py diff --git a/processing/pre/geom_fromVPSC.py b/processing/pre/geom_fromVPSC.py deleted file mode 100755 index 9c6940c41..000000000 --- a/processing/pre/geom_fromVPSC.py +++ /dev/null @@ -1,185 +0,0 @@ -#!/usr/bin/env python2.7 -# -*- coding: UTF-8 no BOM -*- - -import os,sys,math -import numpy as np -from optparse import OptionParser -import damask - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -#-------------------------------------------------------------------------------------------------- -# MAIN -#-------------------------------------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ -Generate geometry description and material configuration from input files used by R.A. Lebensohn. - -""", version = scriptID) - -parser.add_option('--column', dest='column', type='int', metavar = 'int', - help='data column to discriminate between both phases [%default]') -parser.add_option('-t','--threshold', dest='threshold', type='float', metavar = 'float', - help='threshold value for phase discrimination [%default]') -parser.add_option('--homogenization', dest='homogenization', type='int', metavar = 'int', - help='homogenization index for configuration [%default]') -parser.add_option('--phase', dest='phase', type='int', nargs = 2, metavar = 'int int', - help='phase indices for configuration %default') -parser.add_option('--crystallite', dest='crystallite', type='int', metavar = 'int', - help='crystallite index for configuration [%default]') -parser.add_option('--compress', dest='compress', action='store_true', - help='lump identical microstructure and texture information [%default]') -parser.add_option('-p', '--precision', dest='precision', choices=['0','1','2','3'], metavar = 'int', - help = 'euler angles decimal places for output format and compressing {0,1,2,3} [2]') - -parser.set_defaults(column = 7) -parser.set_defaults(threshold = 1.0) -parser.set_defaults(homogenization = 1) -parser.set_defaults(phase = [1,2]) -parser.set_defaults(crystallite = 1) -parser.set_defaults(config = False) -parser.set_defaults(compress = False) -parser.set_defaults(precision = '2') - -(options,filenames) = parser.parse_args() - -if filenames == []: filenames = [None] - -for name in filenames: - try: - table = damask.ASCIItable(name = name, - outname = os.path.splitext(name)[-2]+'.geom' if name else name, - buffered = False, - labeled = False) - except: continue - damask.util.report(scriptName,name) - - info = { - 'grid': np.zeros(3,'i'), - 'size': np.zeros(3,'d'), - 'origin': np.zeros(3,'d'), - 'microstructures': 0, - 'homogenization': options.homogenization - } - - coords = [{},{},{}] - pos = {'min':[ float("inf"), float("inf"), float("inf")], - 'max':[-float("inf"),-float("inf"),-float("inf")]} - - phase = [] - eulerangles = [] - outputAlive = True - -# ------------------------------------------ process data ------------------------------------------ - while outputAlive and table.data_read(): - if table.data != []: - currPos = table.data[3:6] - for i in range(3): - coords[i][currPos[i]] = True - currPos = map(float,currPos) - for i in range(3): - pos['min'][i] = min(pos['min'][i],currPos[i]) - pos['max'][i] = max(pos['max'][i],currPos[i]) - eulerangles.append(map(math.degrees,map(float,table.data[:3]))) - phase.append(options.phase[int(float(table.data[options.column-1]) > options.threshold)]) - -# --------------- determine size and grid --------------------------------------------------------- - info['grid'] = np.array(map(len,coords),'i') - info['size'] = info['grid']/np.maximum(np.ones(3,'d'),info['grid']-1.0)* \ - np.array([pos['max'][0]-pos['min'][0], - pos['max'][1]-pos['min'][1], - pos['max'][2]-pos['min'][2]],'d') - eulerangles = np.array(eulerangles,dtype='f').reshape(info['grid'].prod(),3) - phase = np.array(phase,dtype='i').reshape(info['grid'].prod()) - - limits = [360,180,360] - if any([np.any(eulerangles[:,i]>=limits[i]) for i in [0,1,2]]): - damask.util.croak.write('Error: euler angles out of bound. Ang file might contain unidexed poins.\n') - for i,angle in enumerate(['phi1','PHI','phi2']): - for n in np.nditer(np.where(eulerangles[:,i]>=limits[i]),['zerosize_ok']): - damask.util.croak.write('%s in line %i (%4.2f %4.2f %4.2f)\n' - %(angle,n,eulerangles[n,0],eulerangles[n,1],eulerangles[n,2])) - continue - eulerangles=np.around(eulerangles,int(options.precision)) # round to desired precision -# ensure, that rounded euler angles are not out of bounds (modulo by limits) - for i,angle in enumerate(['phi1','PHI','phi2']): - eulerangles[:,i]%=limits[i] - -# scale angles by desired precision and convert to int. create unique integer key from three euler angles by -# concatenating the string representation with leading zeros and store as integer and search unique euler angle keys. -# Texture IDs are the indices of the first occurrence, the inverse is used to construct the microstructure -# create a microstructure (texture/phase pair) for each point using unique texture IDs. -# Use longInt (64bit, i8) because the keys might be long - if options.compress: - formatString='{0:0>'+str(int(options.precision)+3)+'}' - euleranglesRadInt = (eulerangles*10**int(options.precision)).astype('int') - eulerKeys = np.array([int(''.join(map(formatString.format,euleranglesRadInt[i,:]))) \ - for i in range(info['grid'].prod())]) - devNull, texture, eulerKeys_idx = np.unique(eulerKeys, return_index = True, return_inverse=True) - msFull = np.array([[eulerKeys_idx[i],phase[i]] for i in range(info['grid'].prod())],'i8') - devNull,msUnique,matPoints = np.unique(msFull.view('c16'),True,True) - matPoints+=1 - microstructure = np.array([msFull[i] for i in msUnique]) # pick only unique microstructures - else: - texture = np.arange(info['grid'].prod()) - microstructure = np.hstack( zip(texture,phase) ).reshape(info['grid'].prod(),2) # create texture/phase pairs - formatOut = 1+int(math.log10(len(texture))) - - config_header = [] - - formatwidth = 1+int(math.log10(len(microstructure))) - config_header += [''] - for i in range(len(microstructure)): - config_header += ['[Grain%s]'%str(i+1).zfill(formatwidth), - 'crystallite\t%i'%options.crystallite, - '(constituent)\tphase %i\ttexture %i\tfraction 1.0'%(microstructure[i,1],microstructure[i,0]+1) - ] - config_header += [''] - - eulerFormatOut='%%%i.%if'%(int(options.precision)+4,int(options.precision)) - outStringAngles='(gauss) phi1 '+eulerFormatOut+' Phi '+eulerFormatOut+' phi2 '+eulerFormatOut+' scatter 0.0 fraction 1.0' - for i in range(len(texture)): - config_header += ['[Texture%s]'%str(i+1).zfill(formatOut), - outStringAngles%tuple(eulerangles[texture[i],...]) - ] - - table.labels_clear() - table.info_clear() - - info['microstructures'] = len(microstructure) - -#--- report --------------------------------------------------------------------------------------- - damask.util.croak('grid a b c: %s\n'%(' x '.join(map(str,info['grid']))) + - 'size x y z: %s\n'%(' x '.join(map(str,info['size']))) + - 'origin x y z: %s\n'%(' : '.join(map(str,info['origin']))) + - 'homogenization: %i\n'%info['homogenization'] + - 'microstructures: %i\n\n'%info['microstructures']) - - if np.any(info['grid'] < 1): - damask.util.croak('invalid grid a b c.\n') - continue - if np.any(info['size'] <= 0.0): - damask.util.croak('invalid size x y z.\n') - continue - - -#--- write data ----------------------------------------------------------------------------------- - table.info_append([' '.join([scriptID] + sys.argv[1:]), - "grid\ta %i\tb %i\tc %i"%(info['grid'][0],info['grid'][1],info['grid'][2],), - "size\tx %f\ty %f\tz %f"%(info['size'][0],info['size'][1],info['size'][2],), - "origin\tx %f\ty %f\tz %f"%(info['origin'][0],info['origin'][1],info['origin'][2],), - "microstructures\t%i"%info['microstructures'], - "homogenization\t%i"%info['homogenization'], - config_header - ]) - table.head_write() - if options.compress: - table.data = matPoints.reshape(info['grid'][1]*info['grid'][2],info['grid'][0]) - table.data_writeArray('%%%ii'%(formatwidth),delimiter=' ') - else: - table.data = ["1 to %i\n"%(info['microstructures'])] - -# ------------------------------------------ output finalization ----------------------------------- - - table.close() - From 029bb0f41783d9546316f3a38d2d0dbca7de7adb Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 16 Jan 2019 19:15:30 +0100 Subject: [PATCH 231/372] [skip ci] updated version information after successful test of v2.0.2-1420-g11e0297b --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 0ef928226..69cf212af 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1417-gc39b642a +v2.0.2-1420-g11e0297b From 00bcd7c3652aafbb99bc81e5c3492972d7c53264 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 16 Jan 2019 22:59:04 +0100 Subject: [PATCH 232/372] [skip ci] updated version information after successful test of v2.0.2-1421-gda115ca9 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 0ef928226..ab7f198d4 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1417-gc39b642a +v2.0.2-1421-gda115ca9 From 90b829ea906f7be59053aee3564481ffa72f5959 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 17 Jan 2019 22:29:20 +0100 Subject: [PATCH 233/372] preparing for DREAM.3D --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 5ed6a1f60..683bf0074 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 5ed6a1f60b412eb46ff6820cf03b684095ff1f75 +Subproject commit 683bf0074f3fa079989b51f5a67aa593b7577f0b From f81c25bb58796257e87d7e6196d22f1f3d37d251 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Thu, 17 Jan 2019 17:51:38 -0500 Subject: [PATCH 234/372] [skip ci] allow strain softening in phenopowerlaw, i.e. xi_sat might be less than xi_0 --- src/plastic_phenopowerlaw.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 786dcaab2..0fe0f51e8 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -239,7 +239,7 @@ subroutine plastic_phenopowerlaw_init if ( prm%a_slip <= 0.0_pReal) extmsg = trim(extmsg)//' a_slip' if ( prm%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' if (any(prm%xi_slip_0 <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_slip_0' - if (any(prm%xi_slip_sat < prm%xi_slip_0)) extmsg = trim(extmsg)//' xi_slip_sat' + if (any(prm%xi_slip_sat <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_slip_sat' else slipActive allocate(prm%interaction_SlipSlip(0,0)) allocate(prm%xi_slip_0(0)) From ee1d907a1ef4e9b6ea48612ae84c3eecae1e780c Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 18 Jan 2019 01:33:15 +0100 Subject: [PATCH 235/372] [skip ci] updated version information after successful test of v2.0.2-1427-g90b829ea --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 69cf212af..d824e9bb5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1420-g11e0297b +v2.0.2-1427-g90b829ea From e433aea19355ed4e33ed6c3961634eed5d392ea5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 18 Jan 2019 12:16:26 +0100 Subject: [PATCH 236/372] preparing for separation of stress calculation and tangent calculatin --- src/crystallite.f90 | 303 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 240 insertions(+), 63 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 5377052e2..183f36eae 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1,4 +1,6 @@ !-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH @@ -7,6 +9,13 @@ !-------------------------------------------------------------------------------------------------- module crystallite + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element + use material, only: & + homogenization_Ngrains use prec, only: & pReal, & pInt @@ -30,9 +39,9 @@ module crystallite crystallite_subFrac, & !< already calculated fraction of increment crystallite_subStep !< size of next integration step real(pReal), dimension(:,:,:,:), allocatable, public :: & - crystallite_Tstar_v, & !< current 2nd Piola-Kirchhoff stress vector (end of converged time step) - crystallite_Tstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc - crystallite_partionedTstar0_v !< 2nd Piola-Kirchhoff stress vector at start of homog inc + crystallite_Tstar_v, & !< current 2nd Piola-Kirchhoff stress vector (end of converged time step) ToDo: Should be called S, 3x3 + crystallite_Tstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc ToDo: Should be called S, 3x3 + crystallite_partionedTstar0_v !< 2nd Piola-Kirchhoff stress vector at start of homog inc ToDo: Should be called S, 3x3 real(pReal), dimension(:,:,:,:), allocatable, private :: & crystallite_subTstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of crystallite inc crystallite_orientation, & !< orientation as quaternion @@ -146,9 +155,6 @@ subroutine crystallite_init math_inv33, & math_mul33xx33, & math_mul33x33 - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems, & @@ -171,6 +177,7 @@ subroutine crystallite_init implicit none integer(pInt), parameter :: FILEUNIT=434_pInt + logical, dimension(:,:), allocatable :: devNull integer(pInt) :: & c, & !< counter in integration point component loop i, & !< counter in integration point loop @@ -180,7 +187,6 @@ subroutine crystallite_init cMax, & !< maximum number of integration point components iMax, & !< maximum number of integration points eMax, & !< maximum number of elements - nMax, & !< maximum number of ip neighbors myNcomponents, & !< number of components at current IP mySize @@ -193,13 +199,15 @@ subroutine crystallite_init cMax = homogenization_maxNgrains iMax = mesh_maxNips eMax = mesh_NcpElems - nMax = mesh_maxNipNeighbors - +! --------------------------------------------------------------------------- +! ToDo (when working on homogenization): should be 3x3 tensor called S allocate(crystallite_Tstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_partionedTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_subTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_Tstar_v(6,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) @@ -270,43 +278,43 @@ subroutine crystallite_init do o = 1_pInt, 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 ('eulerangles') outputName - crystallite_outputID(o,c) = eulerangles_ID - case ('defgrad','f') outputName - 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 - crystallite_outputID(o,c) = p_ID - case ('s','tstar','secondpiola','2ndpiola') outputName - crystallite_outputID(o,c) = s_ID - case ('elasmatrix') outputName - crystallite_outputID(o,c) = elasmatrix_ID - case ('neighboringip') outputName - crystallite_outputID(o,c) = neighboringip_ID - case ('neighboringelement') outputName - crystallite_outputID(o,c) = neighboringelement_ID - case default outputName - call IO_error(105_pInt,ext_msg=trim(str(o))//' (Crystallite)') - end select outputName + 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 ('eulerangles') outputName + crystallite_outputID(o,c) = eulerangles_ID + case ('defgrad','f') outputName + 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 + crystallite_outputID(o,c) = p_ID + case ('s','tstar','secondpiola','2ndpiola') outputName + crystallite_outputID(o,c) = s_ID + case ('elasmatrix') outputName + crystallite_outputID(o,c) = elasmatrix_ID + case ('neighboringip') outputName + crystallite_outputID(o,c) = neighboringip_ID + case ('neighboringelement') outputName + crystallite_outputID(o,c) = neighboringelement_ID + case default outputName + call IO_error(105_pInt,ext_msg=trim(str(o))//' (Crystallite)') + end select outputName enddo enddo @@ -359,24 +367,24 @@ subroutine crystallite_init !-------------------------------------------------------------------------------------------------- ! initialize -!$OMP PARALLEL DO PRIVATE(myNcomponents) - 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) - 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(math_mul33x33(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 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) + 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(math_mul33x33(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_pInt) ! exit if nonlocal but no ping-pong + 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? crystallite_partionedFp0 = crystallite_Fp0 crystallite_partionedFi0 = crystallite_Fi0 @@ -406,7 +414,7 @@ subroutine crystallite_init 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: ', nMax + write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', mesh_maxNipNeighbors write(6,'(a42,1x,i10)') ' # of nonlocal constituents: ',count(.not. crystallite_localPlasticity) flush(6) endif @@ -858,6 +866,175 @@ subroutine crystallite_stressAndItsTangent(updateJaco) end subroutine crystallite_stressAndItsTangent +!-------------------------------------------------------------------------------------------------- +!> @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_mul33x33, & + math_Mandel6to33, & + math_Mandel33to6, & + math_Plain3333to99, & + math_Plain99to3333, & + math_I3, & + math_mul3333xx3333, & + math_mul33xx33, & + math_invert, & + math_det33 + use mesh, only: & + mesh_element, & + FE_geomtype + use material, only: & + homogenization_Ngrains + use constitutive, only: & + constitutive_SandItsTangents, & + constitutive_LpAndItsTangents, & + constitutive_LiAndItsTangents + + implicit none + integer(pInt) :: & + 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 + + !$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_pInt,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_Tstar_v(1:6,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_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)) + 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)) + enddo;enddo + call math_invert(9_pInt,math_Plain3333to99(lhs_3333),temp_99,error) + if (error) then + call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dFidS = 0.0_pReal + else + dFidS = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + endif + dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS + endif + + call constitutive_LpAndItsTangents(devNull,dLpdS,dLpdFi, & + crystallite_Tstar_v(1:6,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(math_mul33x33(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), & + 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), & + crystallite_invFp (1:3,1:3,c,i,e)), & + math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) + + do concurrent(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)), & + crystallite_invFi(1:3,1:3,c,i,e)) & + + math_mul33x33(temp_33_3,dLidS(1:3,1:3,p,o)) + enddo + lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) + & + math_mul3333xx3333(dSdFi,dFidS) + + call math_invert(9_pInt,math_identity2nd(9_pInt)+math_Plain3333to99(lhs_3333),temp_99,error) + if (error) then + call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dSdF = rhs_3333 + else + dSdF = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + endif + +!-------------------------------------------------------------------------------------------------- +! calculate dFpinvdF + temp_3333 = math_mul3333xx3333(dLpdS,dSdF) + do concurrent(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))) + enddo + +!-------------------------------------------------------------------------------------------------- +! assemble dPdF + temp_33_1 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & + math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & + transpose(crystallite_invFp(1:3,1:3,c,i,e)))) + temp_33_2 = math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,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), & + 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), & + crystallite_invFp(1:3,1:3,c,i,e)), & + math_Mandel6to33(crystallite_Tstar_v(1:6,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 + crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) + enddo + do concurrent(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))) + enddo + + enddo; enddo + enddo elementLooping + !$OMP END PARALLEL DO + +end subroutine crystallite_stressTangent + + !-------------------------------------------------------------------------------------------------- !> @brief calculates a jump in the state according to the current state and the current stress !> returns true, if state jump was successfull or not needed. false indicates NaN in delta state From 406a2cc5421c1b8c74e2f820aebf7f1c24f76af6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 18 Jan 2019 14:42:44 +0100 Subject: [PATCH 237/372] further separation still using old combined function --- src/crystallite.f90 | 282 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 282 insertions(+) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 183f36eae..90b52cade 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -67,6 +67,7 @@ module crystallite 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) @@ -208,6 +209,7 @@ subroutine crystallite_init allocate(crystallite_Tstar_v(6,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) @@ -407,6 +409,9 @@ subroutine crystallite_init enddo !$OMP END PARALLEL DO + devNull = crystallite_stress() + call crystallite_stressTangent + call crystallite_stressAndItsTangent(.true.) ! request elastic answers #ifdef DEBUG @@ -866,6 +871,283 @@ subroutine crystallite_stressAndItsTangent(updateJaco) end subroutine crystallite_stressAndItsTangent +!-------------------------------------------------------------------------------------------------- +!> @brief calculate stress (P) +!-------------------------------------------------------------------------------------------------- +function crystallite_stress() + 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 +#endif + use IO, only: & + IO_warning, & + IO_error + use math, only: & + math_inv33, & + math_mul33x33, & + math_Mandel6to33, & + math_Mandel33to6 + use mesh, only: & + mesh_NcpElems, & + mesh_element, & + mesh_maxNips, & + FE_geomtype + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + use constitutive, only: & + constitutive_SandItsTangents, & + constitutive_LpAndItsTangents, & + constitutive_LiAndItsTangents + + implicit none + logical, dimension(mesh_maxNips,mesh_NcpElems) :: crystallite_stress + real(pReal) :: & + formerSubStep + integer(pInt) :: & + 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_pInt & + .and. FEsolving_execElem(1) <= debug_e & + .and. debug_e <= FEsolving_execElem(2)) then + write(6,'(/,a,i8,1x,i2,1x,i3)') '<< CRYST >> boundary values at el ip ipc ', & + debug_e,debug_i, debug_g + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F ', & + transpose(crystallite_partionedF(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F0 ', & + transpose(crystallite_partionedF0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fp0', & + transpose(crystallite_partionedFp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi0', & + transpose(crystallite_partionedFi0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Lp0', & + transpose(crystallite_partionedLp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> 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_pInt,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)) + 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) = math_Mandel6to33(crystallite_partionedTstar0_v(1:6,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_pInt + endIP = mesh_maxNips + endif singleRun + + NiterationCrystallite = 0_pInt + cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) +#ifdef DEBUG + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> 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)) +!-------------------------------------------------------------------------------------------------- +! 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)) + + 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) = math_mandel6to33(crystallite_Tstar_v(1:6,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_pInt, 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 & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> 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 + +!-------------------------------------------------------------------------------------------------- +! 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_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) + crystallite_Tstar_v(1:6,c,i,e) = math_mandel33to6(crystallite_subS0(1:3,1:3,c,i,e)) + 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)) + 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) +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then + if (crystallite_todo(c,i,e)) then + write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> cutback step in crystallite_stress & + &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 >> reached minimum step size & + &in crystallite_stress at el ip ipc ',e,i,c + 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) = math_mul33x33(math_mul33x33(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 + +#ifdef DEBUG + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST >> ',minval(crystallite_subStep),' ≤ subStep ≤ ',maxval(crystallite_subStep) + write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST >> ',minval(crystallite_subFrac),' ≤ subFrac ≤ ',maxval(crystallite_subFrac) + flush(6) + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt) then + write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST >> 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 & fully cutbacked any further + crystallite_todo = .true. ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation + + NiterationCrystallite = NiterationCrystallite + 1_pInt + + 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) ! iterate over IPs of this element to be processed + 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) ! iterate over IPs of this element to be processed + 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) & + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> no convergence at el ip ipc ', & + e,i,c + endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> central solution of cryst_StressAndTangent at el ip ipc ',e,i,c + write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST >> 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 >> Fp', & + transpose(crystallite_Fp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi', & + transpose(crystallite_Fi(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Lp', & + transpose(crystallite_Lp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Li', & + transpose(crystallite_Li(1:3,1:3,c,i,e)) + flush(6) + endif + enddo + enddo + enddo elementLooping6 +#endif + +end function crystallite_stress + + !-------------------------------------------------------------------------------------------------- !> @brief calculate tangent (dPdF) !-------------------------------------------------------------------------------------------------- From 221c587362a693901eb947b72f7071b158030dce Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 18 Jan 2019 15:30:50 +0100 Subject: [PATCH 238/372] using separate functions for stress and tangent extensively tested in 46-simplification-of-crystallite-f90-NEW3 already --- src/crystallite.f90 | 454 +---------------------------------------- src/homogenization.f90 | 11 +- src/math.f90 | 2 + 3 files changed, 14 insertions(+), 453 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 90b52cade..2d25ae94f 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -112,7 +112,8 @@ module crystallite public :: & crystallite_init, & - crystallite_stressAndItsTangent, & + crystallite_stress, & + crystallite_stressTangent, & crystallite_orientations, & crystallite_push33ToRef, & crystallite_postResults @@ -154,7 +155,6 @@ subroutine crystallite_init math_I3, & math_EulerToR, & math_inv33, & - math_mul33xx33, & math_mul33x33 use mesh, only: & mesh_element, & @@ -269,6 +269,7 @@ subroutine crystallite_init end select + do c = 1_pInt, size(config_crystallite) #if defined(__GFORTRAN__) str = ['GfortranBug86277'] @@ -412,8 +413,6 @@ subroutine crystallite_init devNull = crystallite_stress() call crystallite_stressTangent - call crystallite_stressAndItsTangent(.true.) ! request elastic answers - #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then write(6,'(a42,1x,i10)') ' # of elements: ', eMax @@ -431,446 +430,6 @@ subroutine crystallite_init end subroutine crystallite_init -!-------------------------------------------------------------------------------------------------- -!> @brief calculate stress (P) and tangent (dPdF) for crystallites -!-------------------------------------------------------------------------------------------------- -subroutine crystallite_stressAndItsTangent(updateJaco) - 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 -#endif - use IO, only: & - IO_warning, & - IO_error - use math, only: & - math_inv33, & - math_identity2nd, & - math_mul33x33, & - math_mul66x6, & - math_Mandel6to33, & - math_Mandel33to6, & - math_Plain3333to99, & - math_Plain99to3333, & - math_I3, & - math_mul3333xx3333, & - math_mul33xx33, & - math_invert, & - math_det33 - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use mesh, only: & - mesh_element, & - mesh_maxNips, & - mesh_ipNeighborhood, & - FE_NipNeighbors, & - FE_geomtype, & - FE_cellType - use material, only: & - homogenization_Ngrains, & - plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt - use constitutive, only: & - constitutive_SandItsTangents, & - constitutive_LpAndItsTangents, & - constitutive_LiAndItsTangents - - implicit none - logical, intent(in) :: & - updateJaco !< whether to update the Jacobian (stiffness) or not - real(pReal) :: & - formerSubStep, & - subFracIntermediate - real(pReal), dimension(3,3) :: & - invFp, & ! inverse of the plastic deformation gradient - Fe_guess, & ! guess for elastic deformation gradient - Tstar ! 2nd Piola-Kirchhoff stress tensor - integer(pInt) :: & - 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 - n, startIP, endIP, & - neighboring_e, & - neighboring_i, & - o, & - p, & - mySource - ! local variables used for calculating analytic Jacobian - real(pReal), dimension(3,3) :: temp_33 - 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 - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt & - .and. FEsolving_execElem(1) <= debug_e & - .and. debug_e <= FEsolving_execElem(2)) then - write(6,'(/,a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> boundary values at el ip ipc ', & - debug_e,'(',mesh_element(1,debug_e), ')',debug_i, debug_g - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F ', & - transpose(crystallite_partionedF(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F0 ', & - transpose(crystallite_partionedF0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fp0', & - transpose(crystallite_partionedFp0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi0', & - transpose(crystallite_partionedFi0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Lp0', & - transpose(crystallite_partionedLp0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> 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_pInt,homogenization_Ngrains(mesh_element(3,e)) - 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 mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) - sourceState(phaseAt(c,i,e))%p(mySource)%subState0( :,phasememberAt(c,i,e)) = & - sourceState(phaseAt(c,i,e))%p(mySource)%partionedState0(:,phasememberAt(c,i,e)) - enddo - crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e) ! ...plastic def grad - crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e) ! ...plastic velocity grad - crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e) ! ...intermediate def grad - crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e) ! ...intermediate velocity grad - crystallite_subF0(1:3,1:3,c,i,e) = crystallite_partionedF0(1:3,1:3,c,i,e) ! ...def grad - crystallite_subTstar0_v(1:6,c,i,e) = crystallite_partionedTstar0_v(1:6,c,i,e) !...2nd PK stress - 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 twice the required size - endif - 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_pInt - endIP = mesh_maxNips - endif singleRun - - NiterationCrystallite = 0_pInt - cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i6)') '<< CRYST >> 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) ! iterate over IPs of this element to be processed - 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_subStep(c,i,e) > 0.0_pReal) then - crystallite_subF0(1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e) ! ...def grad - crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp(1:3,1:3,c,i,e) ! ...plastic velocity gradient - crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li(1:3,1:3,c,i,e) ! ...intermediate velocity gradient - crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp(1:3,1:3,c,i,e) ! ...plastic def grad - crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi(1:3,1:3,c,i,e) ! ...intermediate def grad - !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 mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) - sourceState(phaseAt(c,i,e))%p(mySource)%subState0(:,phasememberAt(c,i,e)) = & - sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) - enddo - crystallite_subTstar0_v(1:6,c,i,e) = crystallite_Tstar_v(1:6,c,i,e) ! ...2nd PK stress - crystallite_todo(c,i,e) = .true. -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & - write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> winding forward from ', & - crystallite_subFrac(c,i,e)-formerSubStep,' to current crystallite_subfrac ', & - crystallite_subFrac(c,i,e),' in crystallite_stressAndItsTangent at el ip ipc ',e,i,c -#endif - else ! this crystallite just converged for the entire timestep - crystallite_todo(c,i,e) = .false. ! so done here - endif - - ! --- cutback --- - - elseif (.not. crystallite_converged(c,i,e)) then - crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) ! cut step in half and restore... - crystallite_Fp(1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) ! ...plastic def grad - 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) ! ...intermediate def grad - crystallite_invFi(1:3,1:3,c,i,e) = math_inv33(crystallite_Fi(1:3,1:3,c,i,e)) - crystallite_Lp(1:3,1:3,c,i,e) = crystallite_subLp0(1:3,1:3,c,i,e) ! ...plastic velocity grad - crystallite_Li(1:3,1:3,c,i,e) = crystallite_subLi0(1:3,1:3,c,i,e) ! ...intermediate velocity grad - plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) = & - plasticState (phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) - sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) = & - sourceState(phaseAt(c,i,e))%p(mySource)%subState0(:,phasememberAt(c,i,e)) - enddo - crystallite_Tstar_v(1:6,c,i,e) = crystallite_subTstar0_v(1:6,c,i,e) ! ...2nd PK stress - - ! 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 & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then - if (crystallite_todo(c,i,e)) then - write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> cutback step in crystallite_stressAndItsTangent & - &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 >> reached minimum step size & - &in crystallite_stressAndItsTangent at el ip ipc ',e,i,c - 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) = math_mul33x33(math_mul33x33(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. ! start out non-converged - endif - - enddo ! grains - enddo ! IPs - enddo elementLooping3 - !$OMP END PARALLEL DO - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then - write(6,'(/,a,f8.5)') '<< CRYST >> min(subStep) ',minval(crystallite_subStep) - write(6,'(a,f8.5)') '<< CRYST >> max(subStep) ',maxval(crystallite_subStep) - write(6,'(a,f8.5)') '<< CRYST >> min(subFrac) ',minval(crystallite_subFrac) - write(6,'(a,f8.5,/)') '<< CRYST >> max(subFrac) ',maxval(crystallite_subFrac) - flush(6) - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt) then - write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST >> 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() - where(.not. crystallite_converged .and. crystallite_subStep > subStepMinCryst) & ! do not try non-converged & fully cutbacked any further - crystallite_todo = .true. - - NiterationCrystallite = NiterationCrystallite + 1_pInt - - enddo cutbackLooping - - -! --+>> CHECK FOR NON-CONVERGED CRYSTALLITES <<+-- - - elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) ! iterate over IPs of this element to be processed - do c = 1,homogenization_Ngrains(mesh_element(3,e)) - if (.not. crystallite_converged(c,i,e)) then ! respond fully elastically (might be not required due to becoming terminally ill anyway) -#ifdef DEBUG - if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> no convergence: respond fully elastic at el (elFE) ip ipc ', & - e,'(',mesh_element(1,e),')',i,c -#endif - invFp = math_inv33(crystallite_partionedFp0(1:3,1:3,c,i,e)) - Fe_guess = math_mul33x33(math_mul33x33(crystallite_partionedF(1:3,1:3,c,i,e), invFp), & - math_inv33(crystallite_partionedFi0(1:3,1:3,c,i,e))) - call constitutive_SandItsTangents(Tstar,dSdFe,dSdFi,Fe_guess,crystallite_partionedFi0(1:3,1:3,c,i,e),c,i,e) - crystallite_P(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_partionedF(1:3,1:3,c,i,e), invFp), & - math_mul33x33(Tstar,transpose(invFp))) - endif -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> central solution of cryst_StressAndTangent at el ip ipc ',e,i,c - write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST >> 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 >> Fp', & - transpose(crystallite_Fp(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi', & - transpose(crystallite_Fi(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Lp', & - transpose(crystallite_Lp(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Li', & - transpose(crystallite_Li(1:3,1:3,c,i,e)) - flush(6) - endif -#endif - enddo - enddo - enddo elementLooping5 - - -! --+>> STIFFNESS CALCULATION <<+-- - - computeJacobian: if(updateJaco) then - !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,& - !$OMP rhs_3333,lhs_3333,temp_99,temp_33,temp_3333,error) - elementLooping6: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) ! iterate over IPs of this element to be processed - do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) - call constitutive_SandItsTangents(temp_33,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(temp_33,dLidS,dLidFi,crystallite_Tstar_v(1:6,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 - temp_33 = 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 - lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) + & - crystallite_subdt(c,i,e)*math_mul33x33(temp_33,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(temp_33,dLidS(1:3,1:3,o,p)) - enddo; enddo - call math_invert(9_pInt,math_Plain3333to99(lhs_3333),temp_99,error) - if (error) then - call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & - ext_msg='inversion error in analytic tangent calculation') - dFidS = 0.0_pReal - else - dFidS = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) - endif - dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS - endif - - call constitutive_LpAndItsTangents(temp_33,dLpdS,dLpdFi,crystallite_Tstar_v(1:6,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 - - temp_33 = transpose(math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & - crystallite_invFi(1:3,1:3,c,i,e))) - rhs_3333 = 0.0_pReal - 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) - - temp_3333 = 0.0_pReal - temp_33 = math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & - math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))) - forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & - temp_3333(1:3,1:3,p,o) = math_mul33x33(math_mul33x33(temp_33,dLpdS(1:3,1:3,p,o)), & - crystallite_invFi(1:3,1:3,c,i,e)) - - temp_33 = math_mul33x33(math_mul33x33(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) & - temp_3333(1:3,1:3,p,o) = temp_3333(1:3,1:3,p,o) + math_mul33x33(temp_33,dLidS(1:3,1:3,p,o)) - - lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) + & - math_mul3333xx3333(dSdFi,dFidS) - - call math_invert(9_pInt,math_identity2nd(9_pInt)+math_Plain3333to99(lhs_3333),temp_99,error) - if (error) then - call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & - ext_msg='inversion error in analytic tangent calculation') - dSdF = rhs_3333 - else - dSdF = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) - endif - - dFpinvdF = 0.0_pReal - temp_3333 = math_mul3333xx3333(dLpdS,dSdF) - 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))) - - crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal - temp_33 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & - math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & - transpose(crystallite_invFp(1:3,1:3,c,i,e)))) - forall(p=1_pInt:3_pInt) & - crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33) - - temp_33 = math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & - transpose(crystallite_invFp(1:3,1:3,c,i,e))) - 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) - - temp_33 = math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)) - 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(temp_33,dSdF(1:3,1:3,p,o)), & - transpose(crystallite_invFp(1:3,1:3,c,i,e))) - - temp_33 = math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)), & - math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e))) - 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(temp_33,transpose(dFpinvdF(1:3,1:3,p,o))) - - enddo; enddo - enddo elementLooping6 - !$OMP END PARALLEL DO - endif computeJacobian - -end subroutine crystallite_stressAndItsTangent - - !-------------------------------------------------------------------------------------------------- !> @brief calculate stress (P) !-------------------------------------------------------------------------------------------------- @@ -1169,7 +728,7 @@ subroutine crystallite_stressTangent() math_I3, & math_mul3333xx3333, & math_mul33xx33, & - math_invert, & + math_invert2, & math_det33 use mesh, only: & mesh_element, & @@ -1232,7 +791,7 @@ subroutine crystallite_stressTangent() 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)) enddo;enddo - call math_invert(9_pInt,math_Plain3333to99(lhs_3333),temp_99,error) + call math_invert2(temp_99,error,math_Plain3333to99(lhs_3333)) if (error) then call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & ext_msg='inversion error in analytic tangent calculation') @@ -1267,7 +826,7 @@ subroutine crystallite_stressTangent() lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) + & math_mul3333xx3333(dSdFi,dFidS) - call math_invert(9_pInt,math_identity2nd(9_pInt)+math_Plain3333to99(lhs_3333),temp_99,error) + call math_invert2(temp_99,error,math_identity2nd(9_pInt)+math_Plain3333to99(lhs_3333)) if (error) then call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & ext_msg='inversion error in analytic tangent calculation') @@ -1481,7 +1040,6 @@ logical function integrateStress(& math_mul66x6, & math_mul99x99, & math_inv33, & - math_invert, & math_det33, & math_I3, & math_identity2nd, & diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 4f9b1c19c..2a141da56 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -363,8 +363,8 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_partionedTstar0_v, & crystallite_dt, & crystallite_requested, & - crystallite_converged, & - crystallite_stressAndItsTangent, & + crystallite_stress, & + crystallite_stressTangent, & crystallite_orientations #ifdef DEBUG use debug, only: & @@ -619,7 +619,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) ! crystallite integration ! based on crystallite_partionedF0,.._partionedF ! incrementing by crystallite_dt - call crystallite_stressAndItsTangent(updateJaco) ! request stress and tangent calculation for constituent grains + materialpoint_converged = crystallite_stress() !ToDo: MD not sure if that is the best logic !-------------------------------------------------------------------------------------------------- ! state update @@ -628,9 +628,8 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) IpLooping3: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) if ( materialpoint_requested(i,e) .and. & .not. materialpoint_doneAndHappy(1,i,e)) then - if (.not. all(crystallite_converged(:,i,e))) then + if (.not. materialpoint_converged(i,e)) then materialpoint_doneAndHappy(1:2,i,e) = [.true.,.false.] - materialpoint_converged(i,e) = .false. else materialpoint_doneAndHappy(1:2,i,e) = homogenization_updateState(i,e) materialpoint_converged(i,e) = all(materialpoint_doneAndHappy(1:2,i,e)) ! converged if done and happy @@ -645,6 +644,8 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) NiterationHomog = NiterationHomog + 1_pInt enddo cutBackLooping + + if(updateJaco) call crystallite_stressTangent if (.not. terminallyIll ) then call crystallite_orientations() ! calculate crystal orientations diff --git a/src/math.f90 b/src/math.f90 index 682f3b78e..12f56707a 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -145,6 +145,7 @@ module math math_invert33, & math_invSym3333, & math_invert, & + math_invert2, & math_symmetric33, & math_symmetric66, & math_skew33, & @@ -889,6 +890,7 @@ function math_invSym3333(A) end function math_invSym3333 + !-------------------------------------------------------------------------------------------------- !> @brief invert quadratic matrix of arbitrary dimension ! ToDo: replaces math_invert From 695b331db09542ca241502489b08a24ccdfd756d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 18 Jan 2019 23:09:46 +0100 Subject: [PATCH 239/372] takeover from old 46-XXX branch --- src/crystallite.f90 | 264 +++++++++++++++++++------------------------- 1 file changed, 111 insertions(+), 153 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 2d25ae94f..cadca932f 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -43,7 +43,6 @@ module crystallite crystallite_Tstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc ToDo: Should be called S, 3x3 crystallite_partionedTstar0_v !< 2nd Piola-Kirchhoff stress vector at start of homog inc ToDo: Should be called S, 3x3 real(pReal), dimension(:,:,:,:), allocatable, private :: & - crystallite_subTstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of crystallite inc crystallite_orientation, & !< orientation as quaternion crystallite_orientation0, & !< initial orientation as quaternion crystallite_rotation !< grain rotation away from initial orientation as axis-angle (in degrees) in crystal reference frame @@ -205,7 +204,6 @@ subroutine crystallite_init ! ToDo (when working on homogenization): should be 3x3 tensor called S allocate(crystallite_Tstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_partionedTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_Tstar_v(6,cMax,iMax,eMax), source=0.0_pReal) ! --------------------------------------------------------------------------- @@ -398,16 +396,16 @@ subroutine crystallite_init 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_pInt,homogenization_Ngrains(mesh_element(3,e)) - call constitutive_microstructure(crystallite_orientation, & ! pass orientation to constitutive module - 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 + 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)) + call constitutive_microstructure(crystallite_orientation, & + 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 !$OMP END PARALLEL DO devNull = crystallite_stress() @@ -862,12 +860,12 @@ subroutine crystallite_stressTangent() do p=1_pInt, 3_pInt crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) enddo - do concurrent(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + 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))) - enddo + end forall enddo; enddo enddo elementLooping @@ -1037,22 +1035,14 @@ logical function integrateStress(& use math, only: math_mul33x33, & math_mul33xx33, & math_mul3333xx3333, & - math_mul66x6, & - math_mul99x99, & math_inv33, & math_det33, & math_I3, & math_identity2nd, & - math_Mandel66to3333, & - math_Mandel6to33, & - math_Mandel33to6, & - math_Plain3333to99, & - math_Plain33to9, & - math_Plain9to33, & - math_Plain99to3333 -#ifdef DEBUG - use mesh, only: mesh_element -#endif + math_sym33to6, & + math_3333to99, & + math_33to9, & + math_9to33 implicit none integer(pInt), intent(in):: el, & ! element index @@ -1060,10 +1050,7 @@ logical function integrateStress(& ipc ! grain index real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep - !*** local variables ***! real(pReal), dimension(3,3):: Fg_new, & ! deformation gradient at end of timestep - Fp_current, & ! plastic deformation gradient at start of timestep - Fi_current, & ! intermediate deformation gradient at start 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 @@ -1083,17 +1070,16 @@ logical function integrateStress(& residuumLi, & ! current residuum of intermediate velocity gradient residuumLi_old, & ! last residuum of intermediate velocity gradient deltaLi, & ! direction of next guess - Tstar, & ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration + S, & ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration A, & B, & Fe, & ! elastic deformation gradient temp_33 - real(pReal), dimension(6):: Tstar_v ! 2nd Piola-Kirchhoff Stress in Mandel-Notation real(pReal), dimension(9):: work ! needed for matrix inversion by LAPACK - integer(pInt), dimension(9) :: ipiv ! needed for matrix inversion by LAPACK - real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for NEwton-Raphson scheme) + integer(pInt), 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) + 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 @@ -1128,8 +1114,6 @@ logical function integrateStress(& write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress at el ip ipc ',el,ip,ipc #endif - !* only integrate over fraction of timestep? - if (present(timeFraction)) then dt = crystallite_subdt(ipc,ip,el) * timeFraction Fg_new = crystallite_subF0(1:3,1:3,ipc,ip,el) & @@ -1141,47 +1125,36 @@ logical function integrateStress(& !* feed local variables - - Fp_current = crystallite_subFp0(1:3,1:3,ipc,ip,el) ! "Fp_current" is only used as temp var here... - Lpguess = crystallite_Lp (1:3,1:3,ipc,ip,el) ! ... and take it as first guess - Fi_current = crystallite_subFi0(1:3,1:3,ipc,ip,el) ! intermediate configuration, assume decomposition as F = Fe Fi Fp - Liguess = crystallite_Li (1:3,1:3,ipc,ip,el) ! ... and take it as first guess + 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 - - !* inversion of Fp_current... - - invFp_current = math_inv33(Fp_current) + 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) then - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on inversion of Fp_current at el (elFE) ip ipc ',& - el,'(',mesh_element(1,el),')',ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & - write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp_current',transpose(Fp_current(1:3,1:3)) - endif + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + 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) & + 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 = math_mul33x33(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp - !* inversion of Fi_current... - - invFi_current = math_inv33(Fi_current) + 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) then - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on inversion of Fi_current at el (elFE) ip ipc ',& - el,'(',mesh_element(1,el),')',ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & - write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp_current',transpose(Fi_current(1:3,1:3)) - endif + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + 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) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> current Fi ',transpose(crystallite_subFi0(1:3,1:3,ipc,ip,el)) #endif return endif failedInversionFi - !* start LpLoop with normal step length - + !* start Li loop with normal step length NiterationStressLi = 0_pInt jacoCounterLi = 0_pInt steplengthLi = 1.0_pReal @@ -1189,82 +1162,73 @@ logical function integrateStress(& LiLoop: do NiterationStressLi = NiterationStressLi + 1_pInt - IloopsExeced: if (NiterationStressLi > nStress) then + LiLoopLimit: if (NiterationStressLi > nStress) then #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & - write(6,'(a,i3,a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> integrateStress reached inelastic loop limit',nStress, & - ' at el (elFE) ip ipc ', el,'(',mesh_element(1,el),')',ip,ipc + 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 IloopsExeced + endif LiLoopLimit invFi_new = math_mul33x33(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_pInt jacoCounterLp = 0_pInt steplengthLp = 1.0_pReal residuumLp_old = 0.0_pReal Lpguess_old = Lpguess - LpLoop: do ! inner stress integration loop for consistency with Fi + LpLoop: do NiterationStressLp = NiterationStressLp + 1_pInt - loopsExeced: if (NiterationStressLp > nStress) then + LpLoopLimit: if (NiterationStressLp > nStress) then #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & - write(6,'(a,i3,a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> integrateStress reached loop limit',nStress, & - ' at el (elFE) ip ipc ', el,'(',mesh_element(1,el),')',ip,ipc + 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 loopsExeced + endif LpLoopLimit !* 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) ! current elastic deformation tensor - call constitutive_SandItsTangents(Tstar, 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 - Tstar_v = math_Mandel33to6(Tstar) + Fe = math_mul33x33(math_mul33x33(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, & + math_sym33to6(S), Fi_new, ipc, ip, el) #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i3,/)') '<< CRYST >> stress iteration ', NiterationStressLp + write(6,'(a,i3,/)') '<< CRYST >> stress iteration ', NiterationStressLp write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Lpguess', transpose(Lpguess) write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Fi', transpose(Fi_new) write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Fe', transpose(Fe) - write(6,'(a,/,6(e20.10,1x))') '<< CRYST >> Tstar', Tstar_v - endif -#endif - call constitutive_LpAndItsTangents(Lp_constitutive, dLp_dS, dLp_dFi, & - Tstar_v, Fi_new, ipc, ip, el) - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> S', transpose(S) write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Lp_constitutive', transpose(Lp_constitutive) 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 + 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 ! NaN in residuum... + if (any(IEEE_is_NaN(residuumLp))) then #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3,a)') '<< CRYST >> integrateStress encountered NaN at el (elFE) ip ipc ', & - el,'(',mesh_element(1,el),')',ip,ipc, & - ' ; iteration ', NiterationStressLp,& - ' >> returning..!' + 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 @@ -1276,7 +1240,7 @@ logical function integrateStress(& 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 + Lpguess = Lpguess_old + steplengthLp * deltaLp #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & @@ -1289,40 +1253,38 @@ logical function integrateStress(& !* calculate Jacobian for correction term - if (mod(jacoCounterLp, iJacoLpresiduum) == 0_pInt) then - dFe_dLp = 0.0_pReal 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) + 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) & - - math_Plain3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) + - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST >> dLp_dS', math_Plain3333to99(dLp_dS) - write(6,'(a,1x,e20.10)') '<< CRYST >> dLp_dS norm', norm2(math_Plain3333to99(dLp_dS)) + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST >> dLp_dS', math_3333to99(dLp_dS) + write(6,'(a,1x,e20.10)') '<< CRYST >> dLp_dS norm', norm2(math_3333to99(dLp_dS)) write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST >> dRLp_dLp', dRLp_dLp - math_identity2nd(9_pInt) - write(6,'(a,1x,e20.10)') '<< CRYST >> dRLp_dLp norm', norm2(dRLp_dLp - math_identity2nd(9_pInt)) + write(6,'(a,1x,e20.10)') '<< CRYST >> dRLp_dLp norm', norm2(dRLp_dLp - math_identity2nd(9_pInt)) endif #endif - dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine - work = math_plain33to9(residuumLp) - call dgesv(9,1,dRLp_dLp2,9,ipiv,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp + 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 #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on dR/dLp inversion at el (elFE) ip ipc ', & - el,'(',mesh_element(1,el),')',ip,ipc + 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 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dR_dLp',transpose(dRLp_dLp) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLp',transpose(math_Plain3333to99(dFe_dLp)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dS_dFe_constitutive',transpose(math_Plain3333to99(dS_dFe)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLp_dS_constitutive',transpose(math_Plain3333to99(dLp_dS)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLp',transpose(math_3333to99(dFe_dLp)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dS_dFe_constitutive',transpose(math_3333to99(dS_dFe)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLp_dS_constitutive',transpose(math_3333to99(dLp_dS)) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> A',transpose(A) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> B',transpose(B) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lp_constitutive',transpose(Lp_constitutive) @@ -1332,18 +1294,17 @@ logical function integrateStress(& #endif return endif - deltaLp = - math_plain9to33(work) + deltaLp = - math_9to33(work) endif - jacoCounterLp = jacoCounterLp + 1_pInt ! increase counter for jaco update + jacoCounterLp = jacoCounterLp + 1_pInt Lpguess = Lpguess + steplengthLp * deltaLp enddo LpLoop !* calculate intermediate velocity gradient and its tangent from constitutive law - call constitutive_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, & - Tstar_v, Fi_new, ipc, ip, el) + math_sym33to6(S), Fi_new, ipc, ip, el) #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & @@ -1353,12 +1314,19 @@ logical function integrateStress(& write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Liguess', transpose(Liguess) endif #endif - !* update current residuum and check for convergence of loop + !* 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_pInt) & + 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 @@ -1374,11 +1342,8 @@ logical function integrateStress(& endif !* calculate Jacobian for correction term - if (mod(jacoCounterLi, iJacoLpresiduum) == 0_pInt) then temp_33 = math_mul33x33(math_mul33x33(A,B),invFi_current) - dFe_dLi = 0.0_pReal - dFi_dLi = 0.0_pReal 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 @@ -1387,24 +1352,24 @@ logical function integrateStress(& dFi_dLi(1:3,1:3,o,p) = math_mul33x33(math_mul33x33(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) dRLi_dLi = math_identity2nd(9_pInt) & - - math_Plain3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & - math_mul3333xx3333(dS_dFi, dFi_dLi))) & - - math_Plain3333to99(math_mul3333xx3333(dLi_dFi, dFi_dLi)) - work = math_plain33to9(residuumLi) - call dgesv(9,1,dRLi_dLi,9,ipiv,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li + - 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 #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on dR/dLi inversion at el (elFE) ip ipc ', & - el,'(',mesh_element(1,el),')',ip,ipc + 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 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,*) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dR_dLi',transpose(dRLi_dLi) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLi',transpose(math_Plain3333to99(dFe_dLi)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dS_dFi_constitutive',transpose(math_Plain3333to99(dS_dFi)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLi_dS_constitutive',transpose(math_Plain3333to99(dLi_dS)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLi',transpose(math_3333to99(dFe_dLi)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dS_dFi_constitutive',transpose(math_3333to99(dS_dFi)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLi_dS_constitutive',transpose(math_3333to99(dLi_dS)) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Li_constitutive',transpose(Li_constitutive) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Liguess',transpose(Liguess) endif @@ -1413,23 +1378,22 @@ logical function integrateStress(& return endif - deltaLi = - math_plain9to33(work) + deltaLi = - math_9to33(work) endif - jacoCounterLi = jacoCounterLi + 1_pInt ! increase counter for jaco update + jacoCounterLi = jacoCounterLi + 1_pInt Liguess = Liguess + steplengthLi * deltaLi enddo LiLoop !* calculate new plastic and elastic deformation gradient - invFp_new = math_mul33x33(invFp_current,B) - invFp_new = invFp_new / math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize by det + 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_pInt) then - write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on invFp_new inversion at el (elFE) ip ipc ',& - el,'(',mesh_element(1,el),')',ip,ipc, ' ; iteration ', NiterationStressLp + 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 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & @@ -1438,28 +1402,22 @@ logical function integrateStress(& #endif return endif failedInversionInvFp - Fe_new = math_mul33x33(math_mul33x33(Fg_new,invFp_new),invFi_new) ! calc resulting Fe + Fe_new = math_mul33x33(math_mul33x33(Fg_new,invFp_new),invFi_new) - !* calculate 1st Piola-Kirchhoff stress - - crystallite_P(1:3,1:3,ipc,ip,el) = math_mul33x33(math_mul33x33(Fg_new,invFp_new), & - math_mul33x33(math_Mandel6to33(Tstar_v), & - transpose(invFp_new))) - - !* store local values in global variables - - crystallite_Lp(1:3,1:3,ipc,ip,el) = Lpguess - crystallite_Li(1:3,1:3,ipc,ip,el) = Liguess - crystallite_Tstar_v(1:6,ipc,ip,el) = Tstar_v - 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 +!-------------------------------------------------------------------------------------------------- +! 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_Tstar_v (1:6,ipc,ip,el) = math_sym33to6(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 - !* set return flag to true - - integrateStress = .true. #ifdef DEBUG if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & @@ -1468,7 +1426,7 @@ logical function integrateStress(& write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Cauchy / MPa', & math_mul33x33(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 >> 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 to get correct print out order + transpose(math_mul33x33(Fe_new, math_mul33x33(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp',transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fi',transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)) endif From 30f28c9f4e4b6d056d305e1f1aaf8c40f88d21e9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 18 Jan 2019 23:20:44 +0100 Subject: [PATCH 240/372] do concurrent causes problems on some Intel compilers use forall instead. Mandel/Plain prefixes not needed any more --- src/crystallite.f90 | 49 ++++++++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index cadca932f..314d2ab7d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -456,8 +456,8 @@ function crystallite_stress() use math, only: & math_inv33, & math_mul33x33, & - math_Mandel6to33, & - math_Mandel33to6 + math_6toSym33, & + math_sym33to6 use mesh, only: & mesh_NcpElems, & mesh_element, & @@ -525,8 +525,8 @@ function crystallite_stress() 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) = math_Mandel6to33(crystallite_partionedTstar0_v(1:6,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) = math_6toSym33(crystallite_partionedTstar0_v(1:6,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. @@ -570,7 +570,7 @@ function crystallite_stress() 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) = math_mandel6to33(crystallite_Tstar_v(1:6,c,i,e)) + crystallite_subS0 (1:3,1:3,c,i,e) = math_6toSym33(crystallite_Tstar_v(1:6,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)) @@ -598,7 +598,7 @@ function crystallite_stress() crystallite_invFi(1:3,1:3,c,i,e) = math_inv33(crystallite_Fi (1:3,1:3,c,i,e)) 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) - crystallite_Tstar_v(1:6,c,i,e) = math_mandel33to6(crystallite_subS0(1:3,1:3,c,i,e)) + crystallite_Tstar_v(1:6,c,i,e) = math_sym33to6(crystallite_subS0(1:3,1:3,c,i,e)) 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)) @@ -719,10 +719,9 @@ subroutine crystallite_stressTangent() math_inv33, & math_identity2nd, & math_mul33x33, & - math_Mandel6to33, & - math_Mandel33to6, & - math_Plain3333to99, & - math_Plain99to3333, & + math_6toSym33, & + math_3333to99, & + math_99to3333, & math_I3, & math_mul3333xx3333, & math_mul33xx33, & @@ -789,13 +788,13 @@ subroutine crystallite_stressTangent() 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)) enddo;enddo - call math_invert2(temp_99,error,math_Plain3333to99(lhs_3333)) + 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, & ext_msg='inversion error in analytic tangent calculation') dFidS = 0.0_pReal else - dFidS = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) endif dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS endif @@ -815,46 +814,46 @@ subroutine crystallite_stressTangent() crystallite_invFp (1:3,1:3,c,i,e)), & math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) - do concurrent(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + 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)), & crystallite_invFi(1:3,1:3,c,i,e)) & + math_mul33x33(temp_33_3,dLidS(1:3,1:3,p,o)) - enddo + 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_pInt)+math_Plain3333to99(lhs_3333)) + call math_invert2(temp_99,error,math_identity2nd(9_pInt)+math_3333to99(lhs_3333)) if (error) then call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & ext_msg='inversion error in analytic tangent calculation') dSdF = rhs_3333 else - dSdF = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) endif !-------------------------------------------------------------------------------------------------- ! calculate dFpinvdF temp_3333 = math_mul3333xx3333(dLpdS,dSdF) - do concurrent(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + 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))) - enddo + end forall !-------------------------------------------------------------------------------------------------- ! assemble dPdF temp_33_1 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & - math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & + math_mul33x33(math_6toSym33(crystallite_Tstar_v(1:6,c,i,e)), & transpose(crystallite_invFp(1:3,1:3,c,i,e)))) - temp_33_2 = math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & + temp_33_2 = math_mul33x33(math_6toSym33(crystallite_Tstar_v(1:6,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), & 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), & crystallite_invFp(1:3,1:3,c,i,e)), & - math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e))) + math_6toSym33(crystallite_Tstar_v(1:6,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 @@ -1080,9 +1079,9 @@ logical function integrateStress(& 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 + 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_dLp, & ! partial derivative of elastic deformation gradient dFe_dLi, & dFi_dLi, & dLp_dFi, & @@ -1508,7 +1507,7 @@ function crystallite_postResults(ipc, ip, el) math_det33, & math_I3, & inDeg, & - math_Mandel6to33 + math_6toSym33 use mesh, only: & mesh_element, & mesh_ipVolume, & @@ -1617,7 +1616,7 @@ function crystallite_postResults(ipc, ip, el) case (s_ID) mySize = 9_pInt crystallite_postResults(c+1:c+mySize) = & - reshape(math_Mandel6to33(crystallite_Tstar_v(1:6,ipc,ip,el)),[mySize]) + reshape(math_6toSym33(crystallite_Tstar_v(1:6,ipc,ip,el)),[mySize]) case (elasmatrix_ID) mySize = 36_pInt crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) From e92c7cd59b8141d72274e6cb7fb8cb3e9cb7ddee Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 19 Jan 2019 01:47:25 +0100 Subject: [PATCH 241/372] [skip ci] updated version information after successful test of v2.0.2-1433-g221c5873 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index d824e9bb5..91f106535 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1427-g90b829ea +v2.0.2-1433-g221c5873 From 6fe099b978545e1730b414ce8feb22763286f93d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 19 Jan 2019 09:35:45 +0100 Subject: [PATCH 242/372] [skip ci] re-ordered functions internal/private functions at the end --- src/crystallite.f90 | 593 ++++++++++++++++++++++---------------------- 1 file changed, 297 insertions(+), 296 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 314d2ab7d..3c2ce0560 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -117,13 +117,13 @@ module crystallite crystallite_push33ToRef, & crystallite_postResults private :: & + integrateStress, & integrateState, & integrateStateFPI, & integrateStateEuler, & integrateStateAdaptiveEuler, & integrateStateRK4, & integrateStateRKCK45, & - integrateStress, & stateJump contains @@ -874,99 +874,66 @@ end subroutine crystallite_stressTangent !-------------------------------------------------------------------------------------------------- -!> @brief calculates a jump in the state according to the current state and the current stress -!> returns true, if state jump was successfull or not needed. false indicates NaN in delta state +!> @brief calculates orientations !-------------------------------------------------------------------------------------------------- -logical function stateJump(ipc,ip,el) - use, intrinsic :: & - IEEE_arithmetic - use prec, only: & - dNeq0 -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelExtensive, & - debug_levelSelective -#endif +subroutine crystallite_orientations + use math, only: & + math_rotationalPart33, & + math_RtoQ + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP use material, only: & plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt - use constitutive, only: & - constitutive_collectDeltaState + material_phase, & + homogenization_Ngrains + use mesh, only: & + mesh_element + use lattice, only: & + lattice_qDisorientation + use plastic_nonlocal, only: & + plastic_nonlocal_updateCompatibility implicit none - integer(pInt), intent(in):: & - el, & ! element index - ip, & ! integration point index - ipc ! grain index + integer(pInt) & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + myPhase ! phase - integer(pInt) :: & - c, & - p, & - mySource, & - myOffsetPlasticDeltaState, & - myOffsetSourceDeltaState, & - mySizePlasticDeltaState, & - mySizeSourceDeltaState + ! --- CALCULATE ORIENTATION AND LATTICE ROTATION --- - c = phasememberAt(ipc,ip,el) - p = phaseAt(ipc,ip,el) +!$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)) +! somehow this subroutine is not threadsafe, so need critical statement here; not clear, what exactly the problem is +!$OMP CRITICAL (polarDecomp) + crystallite_orientation(1:4,c,i,e) = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) +!$OMP END CRITICAL (polarDecomp) + crystallite_rotation(1:4,c,i,e) = lattice_qDisorientation(crystallite_orientation0(1:4,c,i,e), &! active rotation from initial + crystallite_orientation(1:4,c,i,e)) ! to current orientation (with no symmetry) + enddo; enddo; enddo +!$OMP END PARALLEL DO + + + ! --- UPDATE SOME ADDITIONAL VARIABLES THAT ARE NEEDED FOR NONLOCAL MATERIAL --- + ! --- we use crystallite_orientation from above, so need a separate loop + + nonlocalPresent: if (any(plasticState%nonLocal)) then +!$OMP PARALLEL DO PRIVATE(myPhase) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + myPhase = material_phase(1,i,e) ! get my phase (non-local models make no sense with more than one grain per material point) + if (plasticState(myPhase)%nonLocal) then ! if nonlocal model + ! --- calculate compatibility and transmissivity between me and my neighbor --- + call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) + endif + enddo; enddo +!$OMP END PARALLEL DO + endif nonlocalPresent - call constitutive_collectDeltaState(crystallite_Tstar_v(1:6,ipc,ip,el), & - crystallite_Fe(1:3,1:3,ipc,ip,el), & - crystallite_Fi(1:3,1:3,ipc,ip,el), & - ipc,ip,el) - - myOffsetPlasticDeltaState = plasticState(p)%offsetDeltaState - mySizePlasticDeltaState = plasticState(p)%sizeDeltaState - - if( any(IEEE_is_NaN(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c)))) then ! NaN occured in deltaState - stateJump = .false. - return - endif - - plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) = & - plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) + & - plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) - - do mySource = 1_pInt, phase_Nsources(p) - myOffsetSourceDeltaState = sourceState(p)%p(mySource)%offsetDeltaState - mySizeSourceDeltaState = sourceState(p)%p(mySource)%sizeDeltaState - if (any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c)))) then ! NaN occured in deltaState - stateJump = .false. - return - endif - sourceState(p)%p(mySource)%state(myOffsetSourceDeltaState + 1_pInt : & - myOffsetSourceDeltaState + mySizeSourceDeltaState,c) = & - sourceState(p)%p(mySource)%state(myOffsetSourceDeltaState + 1_pInt : & - myOffsetSourceDeltaState + mySizeSourceDeltaState,c) + & - sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c) - enddo - -#ifdef DEBUG - if (any(dNeq0(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c))) & - .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) 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:mySizePlasticDeltaState,c) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & - plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) - endif -#endif - - stateJump = .true. - -end function stateJump +end subroutine crystallite_orientations !-------------------------------------------------------------------------------------------------- @@ -996,6 +963,154 @@ function crystallite_push33ToRef(ipc,ip,el, tensor33) end function crystallite_push33ToRef +!-------------------------------------------------------------------------------------------------- +!> @brief return results of particular grain +!-------------------------------------------------------------------------------------------------- +function crystallite_postResults(ipc, ip, el) + use math, only: & + math_qToEuler, & + math_qToEulerAxisAngle, & + math_mul33x33, & + math_det33, & + math_I3, & + inDeg, & + math_6toSym33 + use mesh, only: & + mesh_element, & + mesh_ipVolume, & + mesh_maxNipNeighbors, & + mesh_ipNeighborhood, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype + use material, only: & + plasticState, & + sourceState, & + microstructure_crystallite, & + crystallite_Noutput, & + material_phase, & + material_texture, & + homogenization_Ngrains + use constitutive, only: & + constitutive_homogenizedC, & + constitutive_postResults + + implicit none + integer(pInt), intent(in):: & + el, & !< element index + ip, & !< integration point index + ipc !< grain index + + real(pReal), dimension(1+crystallite_sizePostResults(microstructure_crystallite(mesh_element(4,el))) + & + 1+plasticState(material_phase(ipc,ip,el))%sizePostResults + & + sum(sourceState(material_phase(ipc,ip,el))%p(:)%sizePostResults)) :: & + crystallite_postResults + real(pReal) :: & + detF + integer(pInt) :: & + o, & + c, & + crystID, & + mySize, & + n + + + crystID = microstructure_crystallite(mesh_element(4,el)) + + crystallite_postResults = 0.0_pReal + c = 0_pInt + crystallite_postResults(c+1) = real(crystallite_sizePostResults(crystID),pReal) ! size of results from cryst + c = c + 1_pInt + + do o = 1_pInt,crystallite_Noutput(crystID) + mySize = 0_pInt + select case(crystallite_outputID(o,crystID)) + case (phase_ID) + mySize = 1_pInt + crystallite_postResults(c+1) = real(material_phase(ipc,ip,el),pReal) ! phaseID of grain + case (texture_ID) + mySize = 1_pInt + crystallite_postResults(c+1) = real(material_texture(ipc,ip,el),pReal) ! textureID of grain + case (volume_ID) + mySize = 1_pInt + 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 + crystallite_postResults(c+1:c+mySize) = crystallite_orientation(1:4,ipc,ip,el) ! grain orientation as quaternion + case (eulerangles_ID) + mySize = 3_pInt + crystallite_postResults(c+1:c+mySize) = inDeg & + * math_qToEuler(crystallite_orientation(1:4,ipc,ip,el)) ! grain orientation as Euler angles in degree + case (grainrotation_ID) + mySize = 4_pInt + crystallite_postResults(c+1:c+mySize) = & + math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates + crystallite_postResults(c+4) = inDeg * crystallite_postResults(c+4) ! angle in degree + +! remark: tensor output is of the form 11,12,13, 21,22,23, 31,32,33 +! thus row index i is slow, while column index j is fast. reminder: "row is slow" + + case (defgrad_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_partionedF(1:3,1:3,ipc,ip,el)),[mySize]) + case (fe_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_Fe(1:3,1:3,ipc,ip,el)),[mySize]) + case (fp_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)),[mySize]) + case (fi_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)),[mySize]) + case (lp_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_Lp(1:3,1:3,ipc,ip,el)),[mySize]) + case (li_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_Li(1:3,1:3,ipc,ip,el)),[mySize]) + case (p_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(transpose(crystallite_P(1:3,1:3,ipc,ip,el)),[mySize]) + case (s_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_6toSym33(crystallite_Tstar_v(1:6,ipc,ip,el)),[mySize]) + case (elasmatrix_ID) + mySize = 36_pInt + crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) + case(neighboringelement_ID) + mySize = mesh_maxNipNeighbors + crystallite_postResults(c+1:c+mySize) = 0.0_pReal + forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) + case(neighboringip_ID) + mySize = mesh_maxNipNeighbors + crystallite_postResults(c+1:c+mySize) = 0.0_pReal + forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + 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) & + crystallite_postResults(c+1:size(crystallite_postResults)) = & + constitutive_postResults(crystallite_Tstar_v(1:6,ipc,ip,el), crystallite_Fi(1:3,1:3,ipc,ip,el), & + crystallite_Fe, ipc, ip, el) + +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 @@ -1434,216 +1549,6 @@ logical function integrateStress(& end function integrateStress -!-------------------------------------------------------------------------------------------------- -!> @brief calculates orientations -!-------------------------------------------------------------------------------------------------- -subroutine crystallite_orientations - use math, only: & - math_rotationalPart33, & - math_RtoQ - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - 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(pInt) & - c, & !< counter in integration point component loop - i, & !< counter in integration point loop - e, & !< counter in element loop - myPhase ! phase - - ! --- CALCULATE ORIENTATION AND LATTICE ROTATION --- - -!$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)) -! somehow this subroutine is not threadsafe, so need critical statement here; not clear, what exactly the problem is -!$OMP CRITICAL (polarDecomp) - crystallite_orientation(1:4,c,i,e) = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) -!$OMP END CRITICAL (polarDecomp) - crystallite_rotation(1:4,c,i,e) = lattice_qDisorientation(crystallite_orientation0(1:4,c,i,e), &! active rotation from initial - crystallite_orientation(1:4,c,i,e)) ! to current orientation (with no symmetry) - enddo; enddo; enddo -!$OMP END PARALLEL DO - - - ! --- UPDATE SOME ADDITIONAL VARIABLES THAT ARE NEEDED FOR NONLOCAL MATERIAL --- - ! --- we use crystallite_orientation from above, so need a separate loop - - nonlocalPresent: if (any(plasticState%nonLocal)) then -!$OMP PARALLEL DO PRIVATE(myPhase) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - myPhase = material_phase(1,i,e) ! get my phase (non-local models make no sense with more than one grain per material point) - if (plasticState(myPhase)%nonLocal) then ! if nonlocal model - ! --- calculate compatibility and transmissivity between me and my neighbor --- - call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) - endif - enddo; enddo -!$OMP END PARALLEL DO - endif nonlocalPresent - -end subroutine crystallite_orientations - -!-------------------------------------------------------------------------------------------------- -!> @brief return results of particular grain -!-------------------------------------------------------------------------------------------------- -function crystallite_postResults(ipc, ip, el) - use math, only: & - math_qToEuler, & - math_qToEulerAxisAngle, & - math_mul33x33, & - math_det33, & - math_I3, & - inDeg, & - math_6toSym33 - use mesh, only: & - mesh_element, & - mesh_ipVolume, & - mesh_maxNipNeighbors, & - mesh_ipNeighborhood, & - FE_NipNeighbors, & - FE_geomtype, & - FE_celltype - use material, only: & - plasticState, & - sourceState, & - microstructure_crystallite, & - crystallite_Noutput, & - material_phase, & - material_texture, & - homogenization_Ngrains - use constitutive, only: & - constitutive_homogenizedC, & - constitutive_postResults - - implicit none - integer(pInt), intent(in):: & - el, & !< element index - ip, & !< integration point index - ipc !< grain index - - real(pReal), dimension(1+crystallite_sizePostResults(microstructure_crystallite(mesh_element(4,el))) + & - 1+plasticState(material_phase(ipc,ip,el))%sizePostResults + & - sum(sourceState(material_phase(ipc,ip,el))%p(:)%sizePostResults)) :: & - crystallite_postResults - real(pReal) :: & - detF - integer(pInt) :: & - o, & - c, & - crystID, & - mySize, & - n - - - crystID = microstructure_crystallite(mesh_element(4,el)) - - crystallite_postResults = 0.0_pReal - c = 0_pInt - crystallite_postResults(c+1) = real(crystallite_sizePostResults(crystID),pReal) ! size of results from cryst - c = c + 1_pInt - - do o = 1_pInt,crystallite_Noutput(crystID) - mySize = 0_pInt - select case(crystallite_outputID(o,crystID)) - case (phase_ID) - mySize = 1_pInt - crystallite_postResults(c+1) = real(material_phase(ipc,ip,el),pReal) ! phaseID of grain - case (texture_ID) - mySize = 1_pInt - crystallite_postResults(c+1) = real(material_texture(ipc,ip,el),pReal) ! textureID of grain - case (volume_ID) - mySize = 1_pInt - 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 - crystallite_postResults(c+1:c+mySize) = crystallite_orientation(1:4,ipc,ip,el) ! grain orientation as quaternion - case (eulerangles_ID) - mySize = 3_pInt - crystallite_postResults(c+1:c+mySize) = inDeg & - * math_qToEuler(crystallite_orientation(1:4,ipc,ip,el)) ! grain orientation as Euler angles in degree - case (grainrotation_ID) - mySize = 4_pInt - crystallite_postResults(c+1:c+mySize) = & - math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates - crystallite_postResults(c+4) = inDeg * crystallite_postResults(c+4) ! angle in degree - -! remark: tensor output is of the form 11,12,13, 21,22,23, 31,32,33 -! thus row index i is slow, while column index j is fast. reminder: "row is slow" - - case (defgrad_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_partionedF(1:3,1:3,ipc,ip,el)),[mySize]) - case (fe_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_Fe(1:3,1:3,ipc,ip,el)),[mySize]) - case (fp_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)),[mySize]) - case (fi_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)),[mySize]) - case (lp_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_Lp(1:3,1:3,ipc,ip,el)),[mySize]) - case (li_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_Li(1:3,1:3,ipc,ip,el)),[mySize]) - case (p_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(transpose(crystallite_P(1:3,1:3,ipc,ip,el)),[mySize]) - case (s_ID) - mySize = 9_pInt - crystallite_postResults(c+1:c+mySize) = & - reshape(math_6toSym33(crystallite_Tstar_v(1:6,ipc,ip,el)),[mySize]) - case (elasmatrix_ID) - mySize = 36_pInt - crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) - case(neighboringelement_ID) - mySize = mesh_maxNipNeighbors - crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & - crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) - case(neighboringip_ID) - mySize = mesh_maxNipNeighbors - crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & - 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) & - crystallite_postResults(c+1:size(crystallite_postResults)) = & - constitutive_postResults(crystallite_Tstar_v(1:6,ipc,ip,el), crystallite_Fi(1:3,1:3,ipc,ip,el), & - crystallite_Fe, ipc, ip, el) - -end function crystallite_postResults - - !-------------------------------------------------------------------------------------------------- !> @brief integrate stress, state with adaptive 1st order explicit Euler method !> using Fixed Point Iteration to adapt the stepsize @@ -3429,4 +3334,100 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates a jump in the state according to the current state and the current stress +!> returns true, if state jump was successfull or not needed. false indicates NaN in delta state +!-------------------------------------------------------------------------------------------------- +logical function stateJump(ipc,ip,el) + use, intrinsic :: & + IEEE_arithmetic + use prec, only: & + dNeq0 +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelExtensive, & + debug_levelSelective +#endif + use material, only: & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + use constitutive, only: & + constitutive_collectDeltaState + + implicit none + integer(pInt), intent(in):: & + el, & ! element index + ip, & ! integration point index + ipc ! grain index + + integer(pInt) :: & + c, & + p, & + mySource, & + myOffsetPlasticDeltaState, & + myOffsetSourceDeltaState, & + mySizePlasticDeltaState, & + mySizeSourceDeltaState + + c = phasememberAt(ipc,ip,el) + p = phaseAt(ipc,ip,el) + + call constitutive_collectDeltaState(crystallite_Tstar_v(1:6,ipc,ip,el), & + crystallite_Fe(1:3,1:3,ipc,ip,el), & + crystallite_Fi(1:3,1:3,ipc,ip,el), & + ipc,ip,el) + + myOffsetPlasticDeltaState = plasticState(p)%offsetDeltaState + mySizePlasticDeltaState = plasticState(p)%sizeDeltaState + + if( any(IEEE_is_NaN(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c)))) then ! NaN occured in deltaState + stateJump = .false. + return + endif + + plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & + myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) = & + plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & + myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) + & + plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) + + do mySource = 1_pInt, phase_Nsources(p) + myOffsetSourceDeltaState = sourceState(p)%p(mySource)%offsetDeltaState + mySizeSourceDeltaState = sourceState(p)%p(mySource)%sizeDeltaState + if (any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c)))) then ! NaN occured in deltaState + stateJump = .false. + return + endif + sourceState(p)%p(mySource)%state(myOffsetSourceDeltaState + 1_pInt : & + myOffsetSourceDeltaState + mySizeSourceDeltaState,c) = & + sourceState(p)%p(mySource)%state(myOffsetSourceDeltaState + 1_pInt : & + myOffsetSourceDeltaState + mySizeSourceDeltaState,c) + & + sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c) + enddo + +#ifdef DEBUG + if (any(dNeq0(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c))) & + .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) 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:mySizePlasticDeltaState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & + plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & + myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) + endif +#endif + + stateJump = .true. + +end function stateJump + end module crystallite From 1be4426dc5d10907c86aa3c1c6fe2bf415173cda Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 19 Jan 2019 09:54:37 +0100 Subject: [PATCH 243/372] not needed --- src/crystallite.f90 | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 3c2ce0560..3c04813b7 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1570,9 +1570,6 @@ subroutine integrateStateFPI() use numerics, only: & nState, & rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems @@ -2031,9 +2028,6 @@ subroutine integrateStateEuler() debug_levelExtensive, & debug_levelSelective #endif - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems @@ -2241,9 +2235,6 @@ subroutine integrateStateAdaptiveEuler() #endif use numerics, only: & rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems, & @@ -2565,9 +2556,6 @@ subroutine integrateStateRK4() debug_levelExtensive, & debug_levelSelective #endif - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems @@ -2857,9 +2845,6 @@ subroutine integrateStateRKCK45() #endif use numerics, only: & rTol_crystalliteState - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use mesh, only: & mesh_element, & mesh_NcpElems, & From 443519be72b6fefd6d8049dcabc0718b21ee5fb4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 19 Jan 2019 10:02:04 +0100 Subject: [PATCH 244/372] cleaning no reason to assume that the math functions are not thread safe --- src/crystallite.f90 | 23 ++++------------------- 1 file changed, 4 insertions(+), 19 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 3c04813b7..def5bfd1d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -880,9 +880,6 @@ subroutine crystallite_orientations use math, only: & math_rotationalPart33, & math_RtoQ - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP use material, only: & plasticState, & material_phase, & @@ -898,37 +895,25 @@ subroutine crystallite_orientations integer(pInt) & c, & !< counter in integration point component loop i, & !< counter in integration point loop - e, & !< counter in element loop - myPhase ! phase - - ! --- CALCULATE ORIENTATION AND LATTICE ROTATION --- + 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_pInt,homogenization_Ngrains(mesh_element(3,e)) -! somehow this subroutine is not threadsafe, so need critical statement here; not clear, what exactly the problem is -!$OMP CRITICAL (polarDecomp) crystallite_orientation(1:4,c,i,e) = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) -!$OMP END CRITICAL (polarDecomp) crystallite_rotation(1:4,c,i,e) = lattice_qDisorientation(crystallite_orientation0(1:4,c,i,e), &! active rotation from initial - crystallite_orientation(1:4,c,i,e)) ! to current orientation (with no symmetry) + crystallite_orientation(1:4,c,i,e)) ! to current orientation (with no symmetry) enddo; enddo; enddo !$OMP END PARALLEL DO - - ! --- UPDATE SOME ADDITIONAL VARIABLES THAT ARE NEEDED FOR NONLOCAL MATERIAL --- ! --- we use crystallite_orientation from above, so need a separate loop - nonlocalPresent: if (any(plasticState%nonLocal)) then -!$OMP PARALLEL DO PRIVATE(myPhase) +!$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - myPhase = material_phase(1,i,e) ! get my phase (non-local models make no sense with more than one grain per material point) - if (plasticState(myPhase)%nonLocal) then ! if nonlocal model - ! --- calculate compatibility and transmissivity between me and my neighbor --- + if (plasticState(material_phase(1,i,e))%nonLocal) & ! if nonlocal model call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) - endif enddo; enddo !$OMP END PARALLEL DO endif nonlocalPresent From 93cc840f054d919a1b75fa99462cf169d8230341 Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 19 Jan 2019 12:21:58 +0100 Subject: [PATCH 245/372] [skip ci] updated version information after successful test of v2.0.2-1437-ge112804e --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 91f106535..47e454765 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1433-g221c5873 +v2.0.2-1437-ge112804e From 5ed370701392470fa0f7427d76d929e050b35399 Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 19 Jan 2019 21:03:31 +0100 Subject: [PATCH 246/372] [skip ci] updated version information after successful test of v2.0.2-1442-gfe08ba86 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 47e454765..faa1b471d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1437-ge112804e +v2.0.2-1442-gfe08ba86 From ac9d49f6be4e7c3e7bc22ebe7c4dc880efae8f33 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 22 Jan 2019 23:23:48 +0100 Subject: [PATCH 247/372] state = subState0 + doState * dt this is the usual state update used in all other integrators. also in-line with logic in crystallite_stress --- src/crystallite.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index def5bfd1d..e2f32d84d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2102,13 +2102,13 @@ eIter = FEsolving_execElem(1:2) c = phasememberAt(g,i,e) mySizePlasticDotState = plasticState(p)%sizeDotState plasticState(p)%state( 1:mySizePlasticDotState,c) = & - plasticState(p)%state( 1:mySizePlasticDotState,c) & + plasticState(p)%subState0( 1:mySizePlasticDotState,c) & + plasticState(p)%dotState(1:mySizePlasticDotState,c) & * crystallite_subdt(g,i,e) do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) & + sourceState(p)%p(mySource)%subState0( 1:mySizeSourceDotState,c) & + sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) & * crystallite_subdt(g,i,e) enddo From b1522b1b9d72dce185103e943f3dfb6d6a337dee Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 23 Jan 2019 06:14:19 +0100 Subject: [PATCH 248/372] common function to update dot state --- src/crystallite.f90 | 340 ++++++++++---------------------------------- 1 file changed, 76 insertions(+), 264 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index e2f32d84d..fcc985419 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1764,49 +1764,9 @@ subroutine integrateStateFPI() endif enddo; enddo; enddo !$OMP ENDDO - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after stress integration' -#endif - - ! --- DOT STATE --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - crystallite_todo(g,i,e) = .false. ! ... skip me next time - if (.not. crystallite_localPlasticity(g,i,e)) then ! if me is non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - - endif - - enddo; enddo; enddo - !$OMP ENDDO - +!$OMP END PARALLEL + call update_dotState(1.0_pReal) +!$OMP PARALLEL ! --- UPDATE STATE --- !$OMP DO PRIVATE(dot_prod12,dot_prod22, & @@ -2055,44 +2015,10 @@ eIter = FEsolving_execElem(1:2) singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + call update_dotState(1.0_pReal) + !$OMP PARALLEL - ! --- DOT STATE --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - c = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- UPDATE STATE --- !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) @@ -2284,42 +2210,11 @@ subroutine integrateStateAdaptiveEuler() sourceStateResiduum = 0.0_pReal relSourceStateResiduum = 0.0_pReal +!-------------------------------------------------------------------------------------------------- +! contribution to state and relative residui and from Euler integration + call update_dotState(1.0_pReal) !$OMP PARALLEL - ! --- DOT STATE (EULER INTEGRATION) --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO ! --- STATE UPDATE (EULER INTEGRATION) --- @@ -2605,43 +2500,8 @@ subroutine integrateStateRK4() enddo endif -!-------------------------------------------------------------------------------------------------- -! first Runge-Kutta step - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO + call update_dotState(1.0_pReal) - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - c = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL !-------------------------------------------------------------------------------------------------- ! --- SECOND TO FOURTH RUNGE KUTTA STEP PLUS FINAL INTEGRATION --- @@ -2746,48 +2606,14 @@ subroutine integrateStateRK4() endif enddo; enddo; enddo !$OMP ENDDO - +!$OMP END PARALLEL ! --- dot state and RK dot state--- first3steps: if (n < 4) then - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - timeStepFraction(n)*crystallite_subdt(g,i,e), & ! fraction of original timestep - crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO + call update_dotState(timeStepFraction(n)) endif first3steps - !$OMP END PARALLEL + enddo @@ -2914,43 +2740,7 @@ subroutine integrateStateRKCK45() singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - - ! --- FIRST RUNGE KUTTA STEP --- - - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,cc,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - cc = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + call update_dotState(1.0_pReal) ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- @@ -3064,48 +2854,8 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO - - - ! --- dot state and RK dot state--- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',stage+1_pInt -#endif - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - C(stage)*crystallite_subdt(g,i,e), & ! fraction of original timestep - crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO - !$OMP DO PRIVATE(p,cc,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,cc))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,cc))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO !$OMP END PARALLEL + call update_dotState(C(stage)) enddo @@ -3305,6 +3055,68 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief triggers calculation of all new rates +!> if NaN occurs, crystallite_todo is set to FALSE. Any NaN in a nonlocal propagates to all others +!-------------------------------------------------------------------------------------------------- +subroutine update_dotState(timeFraction) + use, intrinsic :: & + IEEE_arithmetic + use material, only: & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources + use constitutive, only: & + constitutive_collectDotState + + implicit none + + real(pReal), intent(in) :: & + timeFraction + integer(pInt) :: & + e, & !< element index in element loop + i, & !< integration point index in ip loop + g, & !< grain index in grain loop + p, & + c, & + s + logical :: & + NaN + + !$OMP PARALLEL + !$OMP DO PRIVATE (p,c,NaN) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fi(1:3,1:3,g,i,e), & + crystallite_Fp, & + crystallite_subdt(g,i,e)*timeFraction, crystallite_subFrac, 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) + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(s)%dotState(:,c))) + enddo + if (NaN) then + crystallite_todo(g,i,e) = .false. ! this one done (and broken) + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) + !$OMP END CRITICAL (checkTodo) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + +end subroutine update_DotState + + !-------------------------------------------------------------------------------------------------- !> @brief calculates a jump in the state according to the current state and the current stress !> returns true, if state jump was successfull or not needed. false indicates NaN in delta state From 8ad879a8a1c4bdfd0638ef927cd764e851b6872d Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 23 Jan 2019 08:53:23 +0100 Subject: [PATCH 249/372] [skip ci] updated version information after successful test of v2.0.2-1444-gac9d49f6 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index faa1b471d..3011379b2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1442-gfe08ba86 +v2.0.2-1444-gac9d49f6 From 0a6bcadafe7f2656e5539020e6c53e1480c172ff Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 23 Jan 2019 11:51:43 +0100 Subject: [PATCH 250/372] using a function for state update avoids a lot of code repetition --- src/crystallite.f90 | 238 +++++++++++--------------------------------- 1 file changed, 60 insertions(+), 178 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index fcc985419..e1886d4db 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1647,73 +1647,8 @@ subroutine integrateStateFPI() ! --- DOT STATES --- - !$OMP PARALLEL - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - - !$OMP ENDDO - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,*) '<< CRYST >> dotstate ',plasticState(p)%dotState(:,c) -#endif - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) - !$OMP END CRITICAL (checkTodo) - else ! broken one was local... - crystallite_todo(g,i,e) = .false. ! ... done (and broken) - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- UPDATE STATE --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after preguess of state' -#endif - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state(1:mySizePlasticDotState,c) = & - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - + plasticState(p)%dotState (1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP END PARALLEL + call update_dotState(1.0_pReal) + call update_state(1.0_pReal) ! --+>> STATE LOOP <<+-- @@ -2016,43 +1951,11 @@ eIter = FEsolving_execElem(1:2) singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) call update_dotState(1.0_pReal) + call update_State(1.0_pReal) !$OMP PARALLEL - ! --- UPDATE STATE --- - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state( 1:mySizePlasticDotState,c) = & - plasticState(p)%subState0( 1:mySizePlasticDotState,c) & - + plasticState(p)%dotState(1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%subState0( 1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) - enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state (1:mySizePlasticDotState,c) - endif -#endif - endif - enddo; enddo; enddo - !$OMP ENDDO ! --- STATE JUMP --- @@ -2523,42 +2426,11 @@ subroutine integrateStateRK4() endif enddo; enddo; enddo !$OMP ENDDO + !$OMP END PARALLEL - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state (1:mySizePlasticDotState,c) = & - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - + plasticState(p)%dotState (1:mySizePlasticDotState,c) & - * crystallite_subdt(g,i,e) * timeStepFraction(n) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & - * crystallite_subdt(g,i,e) * timeStepFraction(n) - enddo - -#ifdef DEBUG - if (n == 4 & - .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then ! final integration step - - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) - endif -#endif - endif - enddo; enddo; enddo - !$OMP ENDDO - + call update_state(TIMESTEPFRACTION(n)) + !$OMP PARALLEL ! --- state jump --- !$OMP DO @@ -2784,27 +2656,11 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO + !$OMP END PARALLEL - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState (p)%state (1:mySizePlasticDotState, cc) = & - plasticState (p)%subState0(1:mySizePlasticDotState, cc) & - + plasticState (p)%dotState (1:mySizePlasticDotState, cc) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc) & - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO + call update_state(1.0_pReal) !MD: 1.0 correct? + + !$OMP PARALLEL ! --- state jump --- @@ -2908,31 +2764,11 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO + !$OMP END PARALLEL - ! --- state and update --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) then - - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticState(p)%state (1:mySizePlasticDotState,cc) = & - plasticState(p)%subState0(1:mySizePlasticDotState,cc) & - + plasticState(p)%dotState (1:mySizePlasticDotState,cc) & - * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & - + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc)& - * crystallite_subdt(g,i,e) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - + call update_state(1.0_pReal) + +!$OMP PARALLEL ! --- relative residui and state convergence --- !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) @@ -3055,6 +2891,52 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief Standard forwarding of state as state = state0 + dotState * (delta t) +!-------------------------------------------------------------------------------------------------- +subroutine update_state(timeFraction) + use material, only: & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + + implicit none + real(pReal), intent(in) :: & + timeFraction + integer(pInt) :: & + e, & !< element index in element loop + i, & !< integration point index in ip loop + g, & !< grain index in grain loop + p, & + c, & + s, & + mySize + + !$OMP PARALLEL DO PRIVATE(mySize,p,c) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + + mySize = plasticState(p)%sizeDotState + 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) + 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) & + * crystallite_subdt(g,i,e) * timeFraction + enddo + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + +end subroutine update_state + + !-------------------------------------------------------------------------------------------------- !> @brief triggers calculation of all new rates !> if NaN occurs, crystallite_todo is set to FALSE. Any NaN in a nonlocal propagates to all others From d37ebca93abf4bed870137938065f4c229e58dd1 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 23 Jan 2019 14:27:57 +0100 Subject: [PATCH 251/372] [skip ci] updated version information after successful test of v2.0.2-1447-gd9853e92 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 3011379b2..782c96d00 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1444-gac9d49f6 +v2.0.2-1447-gd9853e92 From c60bb2edd395cfd6379205a79868e73663d96bf8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 23 Jan 2019 18:04:19 +0100 Subject: [PATCH 252/372] function for update of dependent state not introduced everywhere --- src/crystallite.f90 | 103 +++++++++++++++++++------------------------- 1 file changed, 44 insertions(+), 59 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index e1886d4db..4b5dcd21e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1975,20 +1975,10 @@ eIter = FEsolving_execElem(1:2) enddo; enddo; enddo !$OMP ENDDO - - ! --- UPDATE DEPENDENT STATES --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO !$OMP END PARALLEL + call update_dependentState + !$OMP PARALLEL ! --- STRESS INTEGRATION --- @@ -2204,16 +2194,9 @@ subroutine integrateStateAdaptiveEuler() !$OMP PARALLEL ! --- DOT STATE (HEUN METHOD) --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & - crystallite_Fe, & - crystallite_Fi(1:3,1:3,g,i,e), & - crystallite_Fp, & - crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) - enddo; enddo; enddo - !$OMP ENDDO + !$OMP END PARALLEL + call update_dotState(1.0_pReal) + !$OMP PARALLEL !$OMP DO PRIVATE(p,c,NaN) do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains !$OMP FLUSH(crystallite_todo) @@ -2447,19 +2430,9 @@ subroutine integrateStateRK4() endif enddo; enddo; enddo !$OMP ENDDO - - - ! --- update dependent states --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO + !$OMP END PARALLEL + call update_dependentState + !$OMP PARALLEL ! --- stress integration --- @@ -2679,20 +2652,12 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO + !$OMP END PARALLEL - ! --- update dependent states --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO + call update_dependentState + !$OMP PARALLEL ! --- stress integration --- @@ -2836,21 +2801,11 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO + !$OMP END PARALLEL + call update_dependentState -!-------------------------------------------------------------------------------------------------- -! --- UPDATE DEPENDENT STATES IF RESIDUUM BELOW TOLERANCE --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO - - + !$OMP PARALLEL !-------------------------------------------------------------------------------------------------- ! --- FINAL STRESS INTEGRATION STEP IF RESIDUUM BELOW TOLERANCE --- !$OMP DO @@ -2891,6 +2846,36 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief tbd +!-------------------------------------------------------------------------------------------------- +subroutine update_dependentState() + use material, only: & + plasticState + use constitutive, only: & + constitutive_dependentState => constitutive_microstructure + + implicit none + integer(pInt) :: e, & ! element index in element loop + i, & ! integration point index in ip loop + g ! grain index in grain loop + + !$OMP PARALLEL + !$OMP DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_dependentState(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + +end subroutine update_dependentState + !-------------------------------------------------------------------------------------------------- !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- From 164fe35ac584cec053668e3f18cff21ea8b5cd35 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 23 Jan 2019 19:45:44 +0100 Subject: [PATCH 253/372] [skip ci] updated version information after successful test of v2.0.2-1450-gf18c6c53 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 782c96d00..58c7bd70c 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1447-gd9853e92 +v2.0.2-1450-gf18c6c53 From ae931c49a14d45b56b0c854e48aefd3325a1d59e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 23 Jan 2019 23:02:21 +0100 Subject: [PATCH 254/372] more "building block" separation --- src/crystallite.f90 | 97 +++++++++++++++------------------------------ 1 file changed, 31 insertions(+), 66 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 4b5dcd21e..70993d034 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -656,9 +656,9 @@ function crystallite_stress() #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 & 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 NiterationCrystallite = NiterationCrystallite + 1_pInt @@ -1579,6 +1579,7 @@ subroutine integrateStateFPI() g, & !< grain index in grain loop p, & c, & + s, & mySource, & mySizePlasticDotState, & ! size of dot states mySizeSourceDotState @@ -1617,36 +1618,8 @@ subroutine integrateStateFPI() write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo at start of state integration' #endif -!-------------------------------------------------------------------------------------------------- -! initialize dotState - if (.not. singleRun) then - forall(p = 1_pInt:size(plasticState)) - plasticState(p)%previousDotState = 0.0_pReal - plasticState(p)%previousDotState2 = 0.0_pReal - end forall - do p = 1_pInt, size(sourceState); do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState = 0.0_pReal - sourceState(p)%p(mySource)%previousDotState2 = 0.0_pReal - enddo; enddo - else - e = eIter(1) - i = iIter(1,e) - do g = gIter(1,e), gIter(2,e) - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - plasticState(p)%previousDotState (:,c) = 0.0_pReal - plasticState(p)%previousDotState2(:,c) = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState (:,c) = 0.0_pReal - sourceState(p)%p(mySource)%previousDotState2(:,c) = 0.0_pReal - enddo - enddo - endif ! --+>> PREGUESS FOR STATE <<+-- - - ! --- DOT STATES --- - call update_dotState(1.0_pReal) call update_state(1.0_pReal) @@ -1657,27 +1630,32 @@ subroutine integrateStateFPI() crystalliteLooping: do while (.not. doneWithIntegration .and. NiterationState < nState) NiterationState = NiterationState + 1_pInt - !$OMP PARALLEL + ! store previousDotState and previousDotState2 + !$OMP PARALLEL DO PRIVATE(p,c) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - ! --- UPDATE DEPENDENT STATES --- - - !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - plasticState(p)%previousDotState2(:,c) = plasticState(p)%previousDotState(:,c) - plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%previousDotState2(:,c) = sourceState(p)%p(mySource)%previousDotState(:,c) - sourceState(p)%p(mySource)%previousDotState (:,c) = sourceState(p)%p(mySource)%dotState(:,c) + plasticState(p)%previousDotState2(:,c) = merge(plasticState(p)%previousDotState(:,c),& + 0.0_pReal,& + NiterationState > 1_pInt) + plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) + do s = 1_pInt, phase_Nsources(p) + sourceState(p)%p(s)%previousDotState2(:,c) = merge(sourceState(p)%p(s)%previousDotState(:,c),& + 0.0_pReal, & + NiterationState > 1_pInt) + sourceState(p)%p(s)%previousDotState (:,c) = sourceState(p)%p(s)%dotState(:,c) + enddo + endif enddo - enddo; enddo; enddo - !$OMP ENDDO + enddo + enddo + !$OMP END PARALLEL DO + + call update_dependentState + !$OMP PARALLEL ! --- STRESS INTEGRATION --- @@ -2158,21 +2136,10 @@ subroutine integrateStateAdaptiveEuler() endif enddo; enddo; enddo !$OMP ENDDO - - - ! --- UPDATE DEPENDENT STATES (EULER INTEGRATION) --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e)) & - call constitutive_microstructure(crystallite_orientation, & - crystallite_Fe(1:3,1:3,g,i,e), & - crystallite_Fp(1:3,1:3,g,i,e), & - g, i, e) ! update dependent state variables to be consistent with basic states - enddo; enddo; enddo - !$OMP ENDDO !$OMP END PARALLEL + call update_dependentState + ! --- STRESS INTEGRATION (EULER INTEGRATION) --- @@ -2191,11 +2158,9 @@ subroutine integrateStateAdaptiveEuler() enddo; enddo; enddo !$OMP END PARALLEL DO - !$OMP PARALLEL - ! --- DOT STATE (HEUN METHOD) --- - !$OMP END PARALLEL call update_dotState(1.0_pReal) + !$OMP PARALLEL !$OMP DO PRIVATE(p,c,NaN) do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains From 1cccd761cd0498c8fc8c45c704a7169bfd376989 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 23 Jan 2019 23:18:14 +0100 Subject: [PATCH 255/372] variables were not used --- src/crystallite.f90 | 29 ++++++----------------------- 1 file changed, 6 insertions(+), 23 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 70993d034..1fcd92705 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1601,7 +1601,6 @@ subroutine integrateStateFPI() tempSourceState logical :: & converged, & - NaN, & singleRun, & ! flag indicating computation for single (g,i,e) triple doneWithIntegration @@ -1890,9 +1889,6 @@ subroutine integrateStateEuler() mesh_element, & mesh_NcpElems use material, only: & - plasticState, & - sourceState, & - phaseAt, phasememberAt, & phase_Nsources, & homogenization_Ngrains use constitutive, only: & @@ -1904,19 +1900,14 @@ subroutine integrateStateEuler() integer(pInt) :: & e, & ! element index in element loop i, & ! integration point index in ip loop - g, & ! grain index in grain loop - p, & ! phase loop - c, & - mySource, & - mySizePlasticDotState, & - mySizeSourceDotState + g ! grain index in grain loop + integer(pInt), dimension(2) :: & eIter ! bounds for element iteration integer(pInt), dimension(2,mesh_NcpElems) :: & iIter, & ! bounds for ip iteration gIter ! bounds for grain iteration logical :: & - NaN, & singleRun ! flag indicating computation for single (g,i,e) triple @@ -2314,14 +2305,11 @@ subroutine integrateStateRK4() p, & ! phase loop c, & n, & - mySource, & - mySizePlasticDotState, & - mySizeSourceDotState + mySource integer(pInt), dimension(2) :: eIter ! bounds for element iteration integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration gIter ! bounds for grain iteration - logical :: NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple + logical :: singleRun ! flag indicating computation for single (g,i,e) triple eIter = FEsolving_execElem(1:2) do e = eIter(1),eIter(2) @@ -2532,7 +2520,6 @@ subroutine integrateStateRKCK45() sourceStateResiduum, & ! residuum from evolution in microstructure relSourceStateResiduum ! relative residuum from evolution in microstructure logical :: & - NaN, & singleRun ! flag indicating computation for single (g,i,e) triple eIter = FEsolving_execElem(1:2) @@ -2815,8 +2802,6 @@ end subroutine integrateStateRKCK45 !> @brief tbd !-------------------------------------------------------------------------------------------------- subroutine update_dependentState() - use material, only: & - plasticState use constitutive, only: & constitutive_dependentState => constitutive_microstructure @@ -2825,8 +2810,7 @@ subroutine update_dependentState() i, & ! integration point index in ip loop g ! grain index in grain loop - !$OMP PARALLEL - !$OMP DO + !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -2836,8 +2820,7 @@ subroutine update_dependentState() crystallite_Fp(1:3,1:3,g,i,e), & g, i, e) enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO end subroutine update_dependentState From e7d344c4e8abfbe5c57f20e947d20aab3749a43a Mon Sep 17 00:00:00 2001 From: Test User Date: Thu, 24 Jan 2019 01:45:33 +0100 Subject: [PATCH 256/372] [skip ci] updated version information after successful test of v2.0.2-1453-g8e56f0d0 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 58c7bd70c..8da7b3148 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1450-gf18c6c53 +v2.0.2-1453-g8e56f0d0 From 74956c02907bceec10320fd8efda1dfe8dc8cdc2 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Wed, 23 Jan 2019 20:56:01 -0500 Subject: [PATCH 257/372] avoid error for empty "name" --- processing/post/viewTable.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/processing/post/viewTable.py b/processing/post/viewTable.py index 309f229e1..d661e4727 100755 --- a/processing/post/viewTable.py +++ b/processing/post/viewTable.py @@ -68,7 +68,7 @@ for name in filenames: (['data'] if options.data else []) + [] ) - damask.util.report(scriptName,name + ('' if details == '' else ' -- '+details)) + damask.util.report(scriptName,(name if name is not None else '') + ('' if details == '' else ' -- '+details)) # ------------------------------------------ output head --------------------------------------- From eee7ad44a715869efc120f022a13996b2fd86d96 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Wed, 23 Jan 2019 20:58:08 -0500 Subject: [PATCH 258/372] [skip ci] updated keywords in config files --- examples/ConfigFiles/Homogenization_None_Dummy.config | 2 +- examples/ConfigFiles/Phase_Isotropic_AluminumIsotropic.config | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/ConfigFiles/Homogenization_None_Dummy.config b/examples/ConfigFiles/Homogenization_None_Dummy.config index 47ffc0afd..fc608c6c4 100644 --- a/examples/ConfigFiles/Homogenization_None_Dummy.config +++ b/examples/ConfigFiles/Homogenization_None_Dummy.config @@ -1,3 +1,3 @@ [directSX] -type none +mech none diff --git a/examples/ConfigFiles/Phase_Isotropic_AluminumIsotropic.config b/examples/ConfigFiles/Phase_Isotropic_AluminumIsotropic.config index 1f78a8856..2a5c53ba7 100644 --- a/examples/ConfigFiles/Phase_Isotropic_AluminumIsotropic.config +++ b/examples/ConfigFiles/Phase_Isotropic_AluminumIsotropic.config @@ -11,11 +11,11 @@ lattice_structure isotropic c11 110.9e9 c12 58.34e9 -taylorfactor 3 +m 3 tau0 31e6 gdot0 0.001 n 20 h0 75e6 tausat 63e6 -w0 2.25 +a 2.25 atol_resistance 1 From a458dc831be5b7148e05e426f61f8abc942e3bc5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 06:56:43 +0100 Subject: [PATCH 259/372] prepare for consistent use of full tensor representation --- src/constitutive.f90 | 20 +++++++++----------- src/crystallite.f90 | 4 +++- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index ccaf01c33..ba6a554a3 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -854,7 +854,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac integer(pInt) :: & ho, & !< homogenization tme, & !< thermal member position - s, & !< counter in source loop + s, & !< counter in source loop instance, of ho = material_homogenizationAt(el) @@ -920,7 +920,7 @@ end subroutine constitutive_collectDotState !> @brief for constitutive models having an instantaneous change of state !> will return false if delta state is not needed/supported by the constitutive model !-------------------------------------------------------------------------------------------------- -subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) +subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) use prec, only: & pReal, & pLongInt @@ -929,8 +929,7 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) debug_constitutive, & debug_levelBasic use math, only: & - math_Mandel6to33, & - math_Mandel33to6, & + math_sym33to6, & math_mul33x33 use material, only: & phasememberAt, & @@ -954,18 +953,17 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element - real(pReal), intent(in), dimension(6) :: & - S6 !< 2nd Piola Kirchhoff stress (vector notation) real(pReal), intent(in), dimension(3,3) :: & + S, & !< 2nd Piola Kirchhoff stress Fe, & !< elastic deformation gradient Fi !< intermediate deformation gradient real(pReal), dimension(3,3) :: & Mp integer(pInt) :: & - s, & !< counter in source loop + i, & instance, of - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(S6)) + Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -975,13 +973,13 @@ subroutine constitutive_collectDeltaState(S6, Fe, Fi, ipc, ip, el) call plastic_kinehardening_deltaState(Mp,instance,of) case (PLASTICITY_NONLOCAL_ID) plasticityType - call plastic_nonlocal_deltaState(math_Mandel33to6(Mp),ip,el) + call plastic_nonlocal_deltaState(math_sym33to6(Mp),ip,el) end select plasticityType - sourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + sourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) - sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) + sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) case (SOURCE_damage_isoBrittle_ID) sourceType call source_damage_isoBrittle_deltaState (constitutive_homogenizedC(ipc,ip,el), Fe, & diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 1fcd92705..01c20a893 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2958,6 +2958,8 @@ logical function stateJump(ipc,ip,el) phaseAt, phasememberAt use constitutive, only: & constitutive_collectDeltaState + use math, only: & + math_6toSym33 implicit none integer(pInt), intent(in):: & @@ -2977,7 +2979,7 @@ logical function stateJump(ipc,ip,el) c = phasememberAt(ipc,ip,el) p = phaseAt(ipc,ip,el) - call constitutive_collectDeltaState(crystallite_Tstar_v(1:6,ipc,ip,el), & + call constitutive_collectDeltaState(math_6toSym33(crystallite_Tstar_v(1:6,ipc,ip,el)), & crystallite_Fe(1:3,1:3,ipc,ip,el), & crystallite_Fi(1:3,1:3,ipc,ip,el), & ipc,ip,el) From a8a5c8eec03500b1276bd91a418e5aef7e7c07cf Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 07:12:20 +0100 Subject: [PATCH 260/372] preparing function for deltaState essential a "stateJump" over all points --- src/crystallite.f90 | 76 +++++++++++++++++++++++++++++++-------------- 1 file changed, 52 insertions(+), 24 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 01c20a893..d1565c9aa 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2932,6 +2932,40 @@ subroutine update_dotState(timeFraction) end subroutine update_DotState +subroutine update_deltaState + + implicit none + integer(pInt) :: & + e, & !< element index in element loop + i, & !< integration point index in ip loop + g, & !< grain index in grain loop + p, & + c, & + s + + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then ! converged and still alive... + crystallite_todo(g,i,e) = stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken + crystallite_converged(g,i,e) = .false. + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + +end subroutine update_deltaState + + !-------------------------------------------------------------------------------------------------- !> @brief calculates a jump in the state according to the current state and the current stress !> returns true, if state jump was successfull or not needed. false indicates NaN in delta state @@ -2971,10 +3005,8 @@ logical function stateJump(ipc,ip,el) c, & p, & mySource, & - myOffsetPlasticDeltaState, & - myOffsetSourceDeltaState, & - mySizePlasticDeltaState, & - mySizeSourceDeltaState + myOffset, & + mySize c = phasememberAt(ipc,ip,el) p = phaseAt(ipc,ip,el) @@ -2984,44 +3016,40 @@ logical function stateJump(ipc,ip,el) crystallite_Fi(1:3,1:3,ipc,ip,el), & ipc,ip,el) - myOffsetPlasticDeltaState = plasticState(p)%offsetDeltaState - mySizePlasticDeltaState = plasticState(p)%sizeDeltaState + myOffset = plasticState(p)%offsetDeltaState + mySize = plasticState(p)%sizeDeltaState - if( any(IEEE_is_NaN(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c)))) then ! NaN occured in deltaState + if( any(IEEE_is_NaN(plasticState(p)%deltaState(1:mySize,c)))) then ! NaN occured in deltaState stateJump = .false. return endif - plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) = & - plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) + & - plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) + 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 mySource = 1_pInt, phase_Nsources(p) - myOffsetSourceDeltaState = sourceState(p)%p(mySource)%offsetDeltaState - mySizeSourceDeltaState = sourceState(p)%p(mySource)%sizeDeltaState - if (any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c)))) then ! NaN occured in deltaState + 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(myOffsetSourceDeltaState + 1_pInt : & - myOffsetSourceDeltaState + mySizeSourceDeltaState,c) = & - sourceState(p)%p(mySource)%state(myOffsetSourceDeltaState + 1_pInt : & - myOffsetSourceDeltaState + mySizeSourceDeltaState,c) + & - sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c) + 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) enddo #ifdef DEBUG - if (any(dNeq0(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c))) & + if (any(dNeq0(plasticState(p)%deltaState(1:mySize,c))) & .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) 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:mySizePlasticDeltaState,c) + 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(myOffsetPlasticDeltaState + 1_pInt : & - myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) + plasticState(p)%state(myOffset + 1_pInt : & + myOffset + mySize,c) endif #endif From c3b48c348440a189b532954715652430ce38a63f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 07:34:30 +0100 Subject: [PATCH 261/372] WIP: update_deltaState --- src/crystallite.f90 | 46 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 44 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index d1565c9aa..bfb5bf833 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2933,22 +2933,64 @@ end subroutine update_DotState subroutine update_deltaState - + use, intrinsic :: & + IEEE_arithmetic + use prec, only: & + dNeq0 +#ifdef DEBUG + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level, & + debug_crystallite, & + debug_levelExtensive, & + debug_levelSelective +#endif + use material, only: & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + use constitutive, only: & + constitutive_collectDeltaState + use math, only: & + math_6toSym33 implicit none integer(pInt) :: & e, & !< element index in element loop i, & !< integration point index in ip loop g, & !< grain index in grain loop p, & + mySize, & + myOffset, & c, & s + logical :: NaN - !$OMP PARALLEL DO + !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) !$OMP FLUSH(crystallite_todo) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then ! converged and still alive... + call constitutive_collectDeltaState(math_6toSym33(crystallite_Tstar_v(1:6,g,i,e)), & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fi(1:3,1:3,g,i,e), & + g,i,e) + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + myOffset = plasticState(p)%offsetDeltaState + mySize = plasticState(p)%sizeDeltaState + NaN = any(IEEE_is_NaN(plasticState(p)%deltaState(1:mySize,c))) + + 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) + + endif + crystallite_todo(g,i,e) = stateJump(g,i,e) !$OMP FLUSH(crystallite_todo) if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken From 30dc8b4831735ee5ba5ab1a6585e8129d8eaa1ff Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 11:33:04 +0100 Subject: [PATCH 262/372] delta state update for all points replaced stateJump, which works only on one point --- src/crystallite.f90 | 132 ++++++++------------------------------------ 1 file changed, 22 insertions(+), 110 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index bfb5bf833..d05cbe764 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1921,32 +1921,8 @@ eIter = FEsolving_execElem(1:2) call update_dotState(1.0_pReal) call update_State(1.0_pReal) - - !$OMP PARALLEL - - - - - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP END PARALLEL - - call update_dependentState + call update_deltaState + call update_dependentState !$OMP PARALLEL @@ -2109,26 +2085,8 @@ subroutine integrateStateAdaptiveEuler() endif enddo; enddo; enddo !$OMP ENDDO - - - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO !$OMP END PARALLEL - + call update_deltaState call update_dependentState @@ -2365,25 +2323,7 @@ subroutine integrateStateRK4() !$OMP END PARALLEL call update_state(TIMESTEPFRACTION(n)) - - !$OMP PARALLEL - ! --- state jump --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + call update_deltaState call update_dependentState !$OMP PARALLEL @@ -2584,31 +2524,8 @@ subroutine integrateStateRKCK45() !$OMP END PARALLEL call update_state(1.0_pReal) !MD: 1.0 correct? - - !$OMP PARALLEL - - - ! --- state jump --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - - - - call update_dependentState + call update_deltaState + call update_dependentState !$OMP PARALLEL ! --- stress integration --- @@ -2736,25 +2653,9 @@ subroutine integrateStateRKCK45() enddo; enddo; enddo !$OMP ENDDO +!$OMP END PARALLEL - ! --- STATE JUMP --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = stateJump(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - + call update_deltaState call update_dependentState !$OMP PARALLEL @@ -2964,11 +2865,12 @@ subroutine update_deltaState p, & mySize, & myOffset, & + mySource, & c, & s logical :: NaN - !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize) + !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize,mySource,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -2988,10 +2890,20 @@ subroutine update_deltaState 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 mySource = 1_pInt, phase_Nsources(p) + myOffset = sourceState(p)%p(mySource)%offsetDeltaState + mySize = sourceState(p)%p(mySource)%sizeDeltaState + NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySize,c))) + + if (.not. NaN) then + 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) + endif + enddo endif - crystallite_todo(g,i,e) = stateJump(g,i,e) + crystallite_todo(g,i,e) = .not. NaN !$OMP FLUSH(crystallite_todo) if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken crystallite_converged(g,i,e) = .false. From fcdab215653b0418e23b3e29cd54d085a347c12e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 14:15:26 +0100 Subject: [PATCH 263/372] avoid flush of full array more clear logic --- src/crystallite.f90 | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index d05cbe764..0595aa197 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2798,15 +2798,17 @@ subroutine update_dotState(timeFraction) c, & s logical :: & - NaN + NaN, & + nonlocalStop + + nonlocalStop = .false. - !$OMP PARALLEL - !$OMP DO PRIVATE (p,c,NaN) + !$OMP PARALLEL DO PRIVATE (p,c,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + !$OMP FLUSH(nonlocalStop) + if (nonlocalStop .or. (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e))) then call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & crystallite_Fe, & crystallite_Fi(1:3,1:3,g,i,e), & @@ -2819,16 +2821,13 @@ subroutine update_dotState(timeFraction) enddo if (NaN) then crystallite_todo(g,i,e) = .false. ! this one done (and broken) - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) - !$OMP END CRITICAL (checkTodo) - endif + if (.not. crystallite_localPlasticity(g,i,e)) nonlocalStop = .True. endif endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO + + if (nonlocalStop) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity end subroutine update_DotState @@ -2868,14 +2867,18 @@ subroutine update_deltaState mySource, & c, & s - logical :: NaN + logical :: & + NaN, & + nonlocalStop + + nonlocalStop = .false. !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize,mySource,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then ! converged and still alive... + !$OMP FLUSH(nonlocalStop) + if (nonlocalStop .or. (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e))) then call constitutive_collectDeltaState(math_6toSym33(crystallite_Tstar_v(1:6,g,i,e)), & crystallite_Fe(1:3,1:3,g,i,e), & crystallite_Fi(1:3,1:3,g,i,e), & @@ -2904,19 +2907,15 @@ subroutine update_deltaState endif crystallite_todo(g,i,e) = .not. NaN - !$OMP FLUSH(crystallite_todo) if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken crystallite_converged(g,i,e) = .false. - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif + if (.not. crystallite_localPlasticity(g,i,e)) nonlocalStop = .true. endif endif enddo; enddo; enddo !$OMP END PARALLEL DO - + if (nonlocalStop) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity + end subroutine update_deltaState From 934a15d73cc5d42847b722c4fa0114fc63853e8e Mon Sep 17 00:00:00 2001 From: Test User Date: Thu, 24 Jan 2019 15:57:55 +0100 Subject: [PATCH 264/372] [skip ci] updated version information after successful test of v2.0.2-1459-gff5de988 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 8da7b3148..f97473c67 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1453-g8e56f0d0 +v2.0.2-1459-gff5de988 From f4fef6448dc5d4e3dafb259b4753c97c33967e81 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Jan 2019 17:59:38 +0100 Subject: [PATCH 265/372] stress integration for all points in one function --- src/crystallite.f90 | 180 ++++++++++++-------------------------------- 1 file changed, 50 insertions(+), 130 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 0595aa197..53ddca1c7 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1654,29 +1654,7 @@ subroutine integrateStateFPI() !$OMP END PARALLEL DO call update_dependentState - !$OMP PARALLEL - - ! --- STRESS INTEGRATION --- - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo before stress integration' -#endif - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ... then all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO -!$OMP END PARALLEL + call update_stress(1.0_pReal) call update_dotState(1.0_pReal) !$OMP PARALLEL ! --- UPDATE STATE --- @@ -1923,36 +1901,14 @@ eIter = FEsolving_execElem(1:2) call update_State(1.0_pReal) call update_deltaState call update_dependentState + call update_stress(1.0_pReal) - !$OMP PARALLEL - ! --- STRESS INTEGRATION --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - - ! --- SET CONVERGENCE FLAG --- - - !$OMP DO + !$OMP PARALLEL DO do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem enddo; enddo; enddo - !$OMP ENDDO - - !$OMP END PARALLEL + !$OMP END PARALLEL DO ! --- CHECK NON-LOCAL CONVERGENCE --- @@ -2088,27 +2044,8 @@ subroutine integrateStateAdaptiveEuler() !$OMP END PARALLEL call update_deltaState call update_dependentState - - - ! --- STRESS INTEGRATION (EULER INTEGRATION) --- - - !$OMP PARALLEL DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP END PARALLEL DO - - - call update_dotState(1.0_pReal) + call update_stress(1.0_pReal) + call update_dotState(1.0_pReal) !$OMP PARALLEL !$OMP DO PRIVATE(p,c,NaN) @@ -2325,26 +2262,7 @@ subroutine integrateStateRK4() call update_state(TIMESTEPFRACTION(n)) call update_deltaState call update_dependentState - !$OMP PARALLEL - - - ! --- stress integration --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e,timeStepFraction(n)) ! fraction of original times step - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO -!$OMP END PARALLEL + call update_stress(TIMESTEPFRACTION(n)) ! --- dot state and RK dot state--- @@ -2526,26 +2444,8 @@ subroutine integrateStateRKCK45() call update_state(1.0_pReal) !MD: 1.0 correct? call update_deltaState call update_dependentState - !$OMP PARALLEL - - ! --- stress integration --- - - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e,C(stage)) ! fraction of original time step - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL - call update_dotState(C(stage)) + call update_stress(C(stage)) + call update_dotState(C(stage)) enddo @@ -2652,31 +2552,13 @@ subroutine integrateStateRKCK45() endif enddo; enddo; enddo !$OMP ENDDO - !$OMP END PARALLEL call update_deltaState call update_dependentState - - !$OMP PARALLEL -!-------------------------------------------------------------------------------------------------- -! --- FINAL STRESS INTEGRATION STEP IF RESIDUUM BELOW TOLERANCE --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - crystallite_todo(g,i,e) = integrateStress(g,i,e) - !$OMP FLUSH(crystallite_todo) - if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - + call update_stress(1.0_pReal) + + !$OMP PARALLEL !-------------------------------------------------------------------------------------------------- ! --- SET CONVERGENCE FLAG --- !$OMP DO @@ -2699,6 +2581,43 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief Standard forwarding of state as state = state0 + dotState * (delta t) +!-------------------------------------------------------------------------------------------------- +subroutine update_stress(timeFraction) + use material, only: & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + + implicit none + real(pReal), intent(in) :: & + timeFraction + integer(pInt) :: & + e, & !< element index in element loop + i, & !< integration point index in ip loop + g + + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = integrateStress(g,i,e,timeFraction) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + +end subroutine update_stress + !-------------------------------------------------------------------------------------------------- !> @brief tbd !-------------------------------------------------------------------------------------------------- @@ -2725,6 +2644,7 @@ subroutine update_dependentState() end subroutine update_dependentState + !-------------------------------------------------------------------------------------------------- !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- From 05e255b70b343305373e018a5190bba155121f2c Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 25 Jan 2019 00:41:13 +0100 Subject: [PATCH 266/372] [skip ci] updated version information after successful test of v2.0.2-1464-g8fabacec --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index f97473c67..a25b1aedf 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1459-gff5de988 +v2.0.2-1464-g8fabacec From 1c4dc2e05f6819c8bf0b4877c61990dc85bd445c Mon Sep 17 00:00:00 2001 From: Satya Gupta Date: Thu, 24 Jan 2019 18:45:25 -0500 Subject: [PATCH 267/372] material_allocatePlasticState now takes care of setting offsetDeltaState --- src/material.f90 | 10 ++++++---- src/plastic_kinematichardening.f90 | 1 - 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/material.f90 b/src/material.f90 index 8356f43c7..d12321235 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -918,7 +918,8 @@ end subroutine material_parseTexture !-------------------------------------------------------------------------------------------------- !> @brief allocates the plastic state of a phase !-------------------------------------------------------------------------------------------------- -subroutine material_allocatePlasticState(phase,NofMyPhase,sizeState,sizeDotState,sizeDeltaState,& +subroutine material_allocatePlasticState(phase,NofMyPhase,& + sizeState,sizeDotState,sizeDeltaState,& Nslip,Ntwin,Ntrans) use numerics, only: & numerics_integrator2 => numerics_integrator ! compatibility hack @@ -936,9 +937,10 @@ subroutine material_allocatePlasticState(phase,NofMyPhase,sizeState,sizeDotState integer(pInt) :: numerics_integrator ! compatibility hack numerics_integrator = numerics_integrator2(1) ! compatibility hack - plasticState(phase)%sizeState = sizeState - plasticState(phase)%sizeDotState = sizeDotState - plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition plasticState(phase)%Nslip = Nslip plasticState(phase)%Ntwin = Ntwin plasticState(phase)%Ntrans= Ntrans diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 690349c96..d70fe68f7 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -302,7 +302,6 @@ subroutine plastic_kinehardening_init call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & prm%totalNslip,0_pInt,0_pInt) plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) - plasticState(p)%offsetDeltaState = sizeDotState !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState From f2882f195a02d8af3072e4ea28fa00e12c049844 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 25 Jan 2019 07:20:05 +0100 Subject: [PATCH 268/372] fuction for convergence check avoid code repetition --- src/crystallite.f90 | 112 +++++++++++++------------------------------- 1 file changed, 32 insertions(+), 80 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 53ddca1c7..af69b1727 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1852,17 +1852,6 @@ end subroutine integrateStateFPI subroutine integrateStateEuler() use, intrinsic :: & IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif use mesh, only: & mesh_element, & mesh_NcpElems @@ -1874,7 +1863,6 @@ subroutine integrateStateEuler() constitutive_microstructure implicit none - integer(pInt) :: & e, & ! element index in element loop i, & ! integration point index in ip loop @@ -1902,14 +1890,7 @@ eIter = FEsolving_execElem(1:2) call update_deltaState call update_dependentState call update_stress(1.0_pReal) - - - !$OMP PARALLEL DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem - enddo; enddo; enddo - !$OMP END PARALLEL DO - + call setConvergenceFlag ! --- CHECK NON-LOCAL CONVERGENCE --- @@ -2048,30 +2029,6 @@ subroutine integrateStateAdaptiveEuler() call update_dotState(1.0_pReal) !$OMP PARALLEL - !$OMP DO PRIVATE(p,c,NaN) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - !$OMP FLUSH(crystallite_todo) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) - NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do mySource = 1_pInt, phase_Nsources(p) - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) - enddo - if (NaN) then ! NaN occured in any dotState - if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... - !$OMP CRITICAL (checkTodo) - crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped - !$OMP END CRITICAL (checkTodo) - else ! if broken local... - crystallite_todo(g,i,e) = .false. ! ... skip this one next time - endif - endif - endif - enddo; enddo; enddo - !$OMP ENDDO - - ! --- ERROR ESTIMATE FOR STATE (HEUN METHOD) --- !$OMP SINGLE @@ -2272,14 +2229,7 @@ subroutine integrateStateRK4() enddo - - - ! --- SET CONVERGENCE FLAG --- - - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definitionem - enddo; enddo; enddo - + call setConvergenceFlag ! --- CHECK NONLOCAL CONVERGENCE --- @@ -2557,17 +2507,7 @@ subroutine integrateStateRKCK45() call update_deltaState call update_dependentState call update_stress(1.0_pReal) - - !$OMP PARALLEL -!-------------------------------------------------------------------------------------------------- -! --- SET CONVERGENCE FLAG --- - !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - 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 ENDDO - - !$OMP END PARALLEL + call setConvergenceFlag ! --- nonlocal convergence check --- @@ -2581,6 +2521,30 @@ subroutine integrateStateRKCK45() end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief Sets convergence flag based on "todo": every point that survived the integration (todo is +! still .true. is considered as converged +!> @details: For explicitEuler, RK4 and RKCK45, adaptive Euler and FPI have their on criteria +!-------------------------------------------------------------------------------------------------- +subroutine setConvergenceFlag() + + implicit none + integer(pInt) :: & + e, & !< element index in element loop + i, & !< integration point index in ip loop + g !< grain index in grain loop + + !OMP DO PARALLEL PRIVATE(i,g) + 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 + !OMP END DO PARALLEL + +end subroutine setConvergenceFlag + + !-------------------------------------------------------------------------------------------------- !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- @@ -2707,7 +2671,6 @@ subroutine update_dotState(timeFraction) constitutive_collectDotState implicit none - real(pReal), intent(in) :: & timeFraction integer(pInt) :: & @@ -2757,16 +2720,6 @@ subroutine update_deltaState IEEE_arithmetic use prec, only: & dNeq0 -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelExtensive, & - debug_levelSelective -#endif use material, only: & plasticState, & sourceState, & @@ -2897,19 +2850,18 @@ 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_pInt:myOffset + mySize,c) = & + plasticState(p)%state(myOffset + 1_pInt:myOffset + mySize,c) + plasticState(p)%deltaState(1:mySize,c) do mySource = 1_pInt, phase_Nsources(p) myOffset = sourceState(p)%p(mySource)%offsetDeltaState - mySize = sourceState(p)%p(mySource)%sizeDeltaState + 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)%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) enddo From c92e8c034d8f7b4c24cd7f095fa428444a346125 Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 25 Jan 2019 07:33:47 +0100 Subject: [PATCH 269/372] [skip ci] updated version information after successful test of v2.0.2-1493-g13f66c9c --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index f97473c67..bd7a310ee 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1459-gff5de988 +v2.0.2-1493-g13f66c9c From 99ef3534469e33afc12a587057c0836dc6edde56 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 25 Jan 2019 13:42:38 +0100 Subject: [PATCH 270/372] more sanity checks structure string can be now of arbitrary length (technically) only fcc,hex,bcc,bct,ort are accepted labels --- src/lattice.f90 | 157 +++++++++++++++++++++++++++++++----------------- 1 file changed, 102 insertions(+), 55 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 69412895c..9be30a5d3 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -869,8 +869,8 @@ subroutine lattice_initializeStructure(myPhase,CoverA) math_mul33x3, & math_trace33, & math_symmetric33, & - math_Mandel33to6, & - math_Mandel3333to66, & + math_sym33to6, & + math_sym3333to66, & math_Voigt66to3333, & math_axisAngleToR, & INRAD, & @@ -908,7 +908,7 @@ subroutine lattice_initializeStructure(myPhase,CoverA) + 6.0_pReal*lattice_C66(1,2,myPhase) & + 2.0_pReal*lattice_C66(4,4,myPhase))! C12iso/(C11iso+C12iso) with C11iso=(3*C11+2*C12+4*C44)/5 and C12iso=(C11+4*C12-2*C44)/5 lattice_C3333(1:3,1:3,1:3,1:3,myPhase) = math_Voigt66to3333(lattice_C66(1:6,1:6,myPhase)) ! Literature data is Voigt - lattice_C66(1:6,1:6,myPhase) = math_Mandel3333to66(lattice_C3333(1:3,1:3,1:3,1:3,myPhase)) ! DAMASK uses Mandel + lattice_C66(1:6,1:6,myPhase) = math_sym3333to66(lattice_C3333(1:3,1:3,1:3,1:3,myPhase)) ! DAMASK uses Mandel-weighting do i = 1_pInt, 6_pInt if (abs(lattice_C66(i,i,myPhase)) @brief Rotated elasticity matrices for twinning in Mandel notation +!> @brief Rotated elasticity matrices for twinning in 66-vector notation !-------------------------------------------------------------------------------------------------- function lattice_C66_twin(Ntwin,C66,structure,CoverA) use IO, only: & @@ -1405,8 +1408,8 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) use math, only: & INRAD, & math_axisAngleToR, & - math_Mandel3333to66, & - math_Mandel66to3333, & + math_sym3333to66, & + math_66toSym3333, & math_rotate_forward3333 implicit none @@ -1420,15 +1423,18 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) real(pReal), dimension(3,3) :: R integer(pInt) :: i + + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_C66_twin: '//trim(structure)) - select case(trim(structure)) + select case(structure(1:3)) case('fcc') coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& trim(structure),0.0_pReal) case('bcc') coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& trim(structure),0.0_pReal) - case('hex','hexagonal') !ToDo: "No alias policy": long or short? + case('hex') coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& 'hex',cOverA) case default @@ -1437,18 +1443,17 @@ function lattice_C66_twin(Ntwin,C66,structure,CoverA) do i = 1, sum(Ntwin) R = math_axisAngleToR(coordinateSystem(1:3,2,i), 180.0_pReal * INRAD) ! ToDo: Why always 180 deg? - lattice_C66_twin(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(math_Mandel66to3333(C66),R)) + lattice_C66_twin(1:6,1:6,i) = math_sym3333to66(math_rotate_forward3333(math_66toSym3333(C66),R)) enddo end function lattice_C66_twin !-------------------------------------------------------------------------------------------------- -!> @brief Rotated elasticity matrices for transformation in Mandel notation +!> @brief Rotated elasticity matrices for transformation in 66-vector notation !> ToDo: Completely untested and incomplete and undocumented !-------------------------------------------------------------------------------------------------- -function lattice_C66_trans(Ntrans,C_parent66, & - structure_target, & - CoverA_trans,a_bcc,a_fcc) +function lattice_C66_trans(Ntrans,C_parent66,structure_target, & + CoverA_trans,a_bcc,a_fcc) use prec, only: & tol_math_check use IO, only: & @@ -1465,21 +1470,25 @@ function lattice_C66_trans(Ntrans,C_parent66, & math_crossproduct implicit none - integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - character(len=*), intent(in) :: & + integer(pInt), dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + character(len=*), intent(in) :: & structure_target !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C_parent66 - real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 - real(pReal), dimension(3,3,3,3) :: C_target_unrotated - real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S - real(pReal) :: a_bcc, a_fcc, CoverA_trans + real(pReal), dimension(6,6), intent(in) :: C_parent66 + real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 + real(pReal), dimension(3,3,3,3) :: C_target_unrotated + real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans + real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S + real(pReal) :: a_bcc, a_fcc, CoverA_trans integer(pInt) :: i + if (len_trim(structure_target) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) + !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + !-------------------------------------------------------------------------------------------------- ! elasticity matrix of the target phase in cube orientation - if (trim(structure_target) == 'hex') then + if (structure_target(1:3) == 'hex') then C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal @@ -1494,10 +1503,10 @@ function lattice_C66_trans(Ntrans,C_parent66, & C_target_unrotated66(3,3) = C_bar66(3,3) C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2.0_pReal/(0.5_pReal*(C_bar66(1,1) - C_bar66(1,2))) C_target_unrotated66 = lattice_symmetrizeC66(LATTICE_HEX_ID,C_target_unrotated66) - elseif (trim(structure_target) == 'bcc') then + elseif (structure_target(1:3) == 'bcc') then C_target_unrotated66 = C_parent66 else - write(6,*) "Mist" + call IO_error(137_pInt,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) endif @@ -1511,7 +1520,7 @@ function lattice_C66_trans(Ntrans,C_parent66, & do i = 1, sum(Ntrans) lattice_C66_trans(1:6,1:6,i) = math_Mandel3333to66(math_rotate_forward3333(C_target_unrotated,Q(1:3,1:3,i))) enddo -end function +end function lattice_C66_trans !-------------------------------------------------------------------------------------------------- @@ -1584,14 +1593,17 @@ function lattice_interaction_SlipSlip(Nslip,interactionValues,structure) result( integer(pInt), dimension(:), allocatable :: NslipMax integer(pInt), dimension(:,:), allocatable :: interactionTypes - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipSlip: '//trim(structure)) + + select case(structure(1:3)) case('fcc') interactionTypes = LATTICE_FCC_INTERACTIONSLIPSLIP NslipMax = LATTICE_FCC_NSLIPSYSTEM case('bcc') interactionTypes = LATTICE_BCC_INTERACTIONSLIPSLIP NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') interactionTypes = LATTICE_HEX_INTERACTIONSLIPSLIP NslipMax = LATTICE_HEX_NSLIPSYSTEM case('bct') @@ -1688,14 +1700,17 @@ function lattice_interaction_TwinTwin(Ntwin,interactionValues,structure) result( 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & ],pInt),shape(HEX_INTERACTIONTWINTWIN),order=[2,1]) !< Twin-twin interaction types for hex - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_TwinTwin: '//trim(structure)) + + select case(structure(1:3)) case('fcc') interactionTypes = FCC_INTERACTIONTWINTWIN NtwinMax = LATTICE_FCC_NTWINSYSTEM case('bcc') interactionTypes = BCC_INTERACTIONTWINTWIN NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') interactionTypes = HEX_INTERACTIONTWINTWIN NtwinMax = LATTICE_HEX_NTWINSYSTEM case default @@ -1740,7 +1755,10 @@ function lattice_interaction_TransTrans(Ntrans,interactionValues,structure) resu 2,2,2,2,2,2,2,2,2,1,1,1 & ],pInt),shape(FCC_INTERACTIONTRANSTRANS),order=[2,1]) !< Trans-trans interaction types for fcc - if (trim(structure) == 'fcc') then + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_TransTrans: '//trim(structure)) + + if(structure(1:3) == 'fcc') then interactionTypes = FCC_INTERACTIONTRANSTRANS NtransMax = LATTICE_FCC_NTRANSSYSTEM else @@ -1870,8 +1888,10 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r ! ],pInt),shape(HEX_INTERACTIONSLIPTWIN),order=[2,1]) !< Slip-twin interaction types for hex - - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipTwin: '//trim(structure)) + + select case(structure(1:3)) case('fcc') interactionTypes = FCC_INTERACTIONSLIPTWIN NslipMax = LATTICE_FCC_NSLIPSYSTEM @@ -1880,7 +1900,7 @@ function lattice_interaction_SlipTwin(Nslip,Ntwin,interactionValues,structure) r interactionTypes = BCC_INTERACTIONSLIPTWIN NslipMax = LATTICE_BCC_NSLIPSYSTEM NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') interactionTypes = HEX_INTERACTIONSLIPTWIN NslipMax = LATTICE_HEX_NSLIPSYSTEM NtwinMax = LATTICE_HEX_NTWINSYSTEM @@ -1936,7 +1956,10 @@ function lattice_interaction_SlipTrans(Nslip,Ntrans,interactionValues,structure) 4,4,4,4,4,4,4,4,4,4,4,4 & ],pInt),shape(FCC_INTERACTIONSLIPTRANS),order=[2,1]) !< Slip-trans interaction types for fcc - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_SlipTrans: '//trim(structure)) + + select case(structure(1:3)) case('fcc') interactionTypes = FCC_INTERACTIONSLIPTRANS NslipMax = LATTICE_FCC_NSLIPSYSTEM @@ -2005,8 +2028,11 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & ],pInt),shape(HEX_INTERACTIONTWINSLIP),order=[2,1]) !< Twin-twin interaction types for hex + + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_interaction_TwinSlip: '//trim(structure)) - select case(structure) + select case(structure(1:3)) case('fcc') interactionTypes = FCC_INTERACTIONTWINSLIP NtwinMax = LATTICE_FCC_NTWINSYSTEM @@ -2015,7 +2041,7 @@ function lattice_interaction_TwinSlip(Ntwin,Nslip,interactionValues,structure) r interactionTypes = BCC_INTERACTIONTWINSLIP NtwinMax = LATTICE_BCC_NTWINSYSTEM NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') interactionTypes = HEX_INTERACTIONTWINSLIP NtwinMax = LATTICE_HEX_NTWINSYSTEM NslipMax = LATTICE_HEX_NSLIPSYSTEM @@ -2051,15 +2077,18 @@ function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) real(pReal), dimension(:,:), allocatable :: slipSystems integer(pInt), dimension(:), allocatable :: NslipMax integer(pInt) :: i + + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) - select case(structure) + select case(structure(1:3)) case('fcc') NslipMax = LATTICE_FCC_NSLIPSYSTEM slipSystems = LATTICE_FCC_SYSTEMSLIP case('bcc') NslipMax = LATTICE_BCC_NSLIPSYSTEM slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') NslipMax = LATTICE_HEX_NSLIPSYSTEM slipSystems = LATTICE_HEX_SYSTEMSLIP case('bct') @@ -2109,14 +2138,17 @@ function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) integer(pInt), dimension(:), allocatable :: NtwinMax integer(pInt) :: i - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) + + select case(structure(1:3)) case('fcc') NtwinMax = LATTICE_FCC_NTWINSYSTEM twinSystems = LATTICE_FCC_SYSTEMTWIN case('bcc') NtwinMax = LATTICE_BCC_NTWINSYSTEM twinSystems = LATTICE_BCC_SYSTEMTWIN - case('hex','hexagonal') !ToDo: "No alias policy": long or short? + case('hex') NtwinMax = LATTICE_HEX_NTWINSYSTEM twinSystems = LATTICE_HEX_SYSTEMTWIN case default @@ -2162,11 +2194,17 @@ function lattice_SchmidMatrix_trans(Ntrans,structure_target,cOverA,a_bcc,a_fcc) real(pReal), dimension(3,3,sum(Ntrans)) :: devNull real(pReal) :: a_bcc, a_fcc -! ToDo: Error checking!!!!!!!!!!!!!!!!!!! + + if (len_trim(structure_target) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') & + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + + !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) - -end function lattice_SchmidMatrix_trans + end function lattice_SchmidMatrix_trans !-------------------------------------------------------------------------------------------------- @@ -2189,8 +2227,11 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid real(pReal), dimension(:,:), allocatable :: cleavageSystems integer(pInt), dimension(:), allocatable :: NcleavageMax integer(pInt) :: i + + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) - select case(structure) + select case(structure(1:3)) case('iso') NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE @@ -2203,7 +2244,7 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(Schmid case('bcc') NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE - case('hex','hexagonal') !ToDo: "No alias policy": long or short? + case('hex') NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE case default @@ -2246,14 +2287,17 @@ function lattice_forestProjection(Nslip,structure,cOverA) result(projection) integer(pInt), dimension(:), allocatable :: NslipMax integer(pInt) :: i, j - select case(structure) + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='lattice_forestProjection: '//trim(structure)) + + select case(structure(1:3)) case('fcc') NslipMax = LATTICE_FCC_NSLIPSYSTEM slipSystems = LATTICE_FCC_SYSTEMSLIP case('bcc') NslipMax = LATTICE_BCC_NSLIPSYSTEM slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex','hexagonal') ! ToDo: "No alias policy": long or short? + case('hex') NslipMax = LATTICE_HEX_NSLIPSYSTEM slipSystems = LATTICE_HEX_SYSTEMSLIP case('bct') @@ -2346,9 +2390,11 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) f, & !< index of my family s !< index of my system in current family - if (trim(structure) == 'bct' .and. cOverA > 2.0_pReal) & + if (len_trim(structure) /= 3_pInt) & + call IO_error(137_pInt,ext_msg='buildCoordinateSystem: '//trim(structure)) + if (trim(structure(1:3)) == 'bct' .and. cOverA > 2.0_pReal) & call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) - if (trim(structure) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & + if (trim(structure(1:3)) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & call IO_error(131_pInt,ext_msg='buildCoordinateSystem:'//trim(structure)) a = 0_pInt @@ -2357,7 +2403,7 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA) a = a + 1_pInt c = sum(complete(1:f-1))+s - select case(trim(structure)) + select case(trim(structure(1:3))) case ('fcc','bcc','iso','ort','bct') direction = system(1:3,c) @@ -2391,7 +2437,7 @@ end function buildCoordinateSystem !> @brief Helper function to define transformation systems ! Needed to calculate Schmid matrix and rotated stiffness matrices. ! @details: set c/a = 0.0 for fcc -> bcc transformation -! set a_bcc = 0.0 for fcc -> bcc transformation +! set a_bcc = 0.0 for fcc -> hex transformation !-------------------------------------------------------------------------------------------------- subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) use prec, only: & @@ -2493,7 +2539,6 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) if (size(Ntrans) < 1_pInt .or. size(Ntrans) > 1_pInt) print*, 'mist' ! ToDo if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation - if (a_bcc <= 0.0_pReal) print*, 'mist' ! ToDo do i = 1_pInt,sum(Ntrans) R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & lattice_fccTobcc_systemTrans(4,i)*INRAD) @@ -2525,6 +2570,8 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) 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 enddo + else + call IO_error(0_pInt) !ToDo: define error endif end subroutine buildTransformationSystem From e9087f83fe1edc850da711d51d4ab53092b4ee1d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 25 Jan 2019 14:01:17 +0100 Subject: [PATCH 271/372] small improvements checking size of arguments (not shape) length of lattice structure not limited to 3 any more --- src/plastic_disloUCLA.f90 | 52 ++++++++++++++---------------- src/plastic_kinematichardening.f90 | 38 +++++++++++----------- src/plastic_phenopowerlaw.f90 | 48 +++++++++++++-------------- 3 files changed, 66 insertions(+), 72 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 94e07fc84..e386a9808 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -93,7 +93,7 @@ module plastic_disloUCLA !-------------------------------------------------------------------------------------------------- ! containers for parameters and state type(tParameters), allocatable, dimension(:), private :: param - type(tDisloUCLAState ), allocatable, dimension(:), private :: & + type(tDisloUCLAState), allocatable, dimension(:), private :: & dotState, & state type(tDisloUCLAdependentState), allocatable, dimension(:), private :: dependentState @@ -164,7 +164,6 @@ subroutine plastic_disloUCLA_init() outputID character(len=pStringLen) :: & - structure = '',& extmsg = '' character(len=65536), dimension(:), allocatable :: & outputs @@ -197,8 +196,6 @@ subroutine plastic_disloUCLA_init() dst => dependentState(phase_plasticityInstance(p)), & config => config_phase(p)) - structure = config%getString('lattice_structure') - !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined prm%mu = lattice_mu(p) @@ -213,36 +210,37 @@ subroutine plastic_disloUCLA_init() prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then - prm%Schmid = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config%getFloat('c/a',defaultVal=0.0_pReal)) - if(structure=='bcc') then - prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& + 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_pInt) + prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) else - prm%nonSchmid_pos = prm%Schmid - prm%nonSchmid_neg = prm%Schmid + prm%nonSchmid_pos = prm%Schmid + prm%nonSchmid_neg = prm%Schmid endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - structure(1:3)) - prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) - prm%rhoDip0 = config%getFloats('rhoedgedip0', requiredShape=shape(prm%Nslip)) - prm%v0 = config%getFloats('v0', requiredShape=shape(prm%Nslip)) - prm%burgers = config%getFloats('slipburgers', requiredShape=shape(prm%Nslip)) - prm%H0kp = config%getFloats('qedge', requiredShape=shape(prm%Nslip)) + config%getString('lattice_structure')) + prm%rho0 = config%getFloats('rhoedge0', requiredSize=size(prm%Nslip)) + prm%rhoDip0 = config%getFloats('rhoedgedip0', requiredSize=size(prm%Nslip)) + prm%v0 = config%getFloats('v0', requiredSize=size(prm%Nslip)) + prm%burgers = config%getFloats('slipburgers', requiredSize=size(prm%Nslip)) + prm%H0kp = config%getFloats('qedge', requiredSize=size(prm%Nslip)) - prm%clambda = config%getFloats('clambdaslip', requiredShape=shape(prm%Nslip)) - prm%tau_Peierls = config%getFloats('tau_peierls', requiredShape=shape(prm%Nslip)) ! ToDo: Deprecated - prm%p = config%getFloats('p_slip', requiredShape=shape(prm%Nslip), & + prm%clambda = config%getFloats('clambdaslip', requiredSize=size(prm%Nslip)) + prm%tau_Peierls = config%getFloats('tau_peierls', requiredSize=size(prm%Nslip)) ! ToDo: Deprecated + prm%p = config%getFloats('p_slip', requiredSize=size(prm%Nslip), & defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) - prm%q = config%getFloats('q_slip', requiredShape=shape(prm%Nslip), & + prm%q = config%getFloats('q_slip', requiredSize=size(prm%Nslip), & defaultVal=[(1.0_pReal,i=1_pInt,size(prm%Nslip))]) - prm%kink_height = config%getFloats('kink_height', requiredShape=shape(prm%Nslip)) - prm%w = config%getFloats('kink_width', requiredShape=shape(prm%Nslip)) - prm%omega = config%getFloats('omega', requiredShape=shape(prm%Nslip)) - prm%B = config%getFloats('friction_coeff', requiredShape=shape(prm%Nslip)) + prm%kink_height = config%getFloats('kink_height', requiredSize=size(prm%Nslip)) + prm%w = config%getFloats('kink_width', requiredSize=size(prm%Nslip)) + prm%omega = config%getFloats('omega', requiredSize=size(prm%Nslip)) + prm%B = config%getFloats('friction_coeff', requiredSize=size(prm%Nslip)) prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') ! ToDo: Deprecated prm%grainSize = config%getFloat('grainsize') @@ -250,7 +248,7 @@ subroutine plastic_disloUCLA_init() prm%Qsd = config%getFloat('qsd') prm%atomicVolume = config%getFloat('catomicvolume') * prm%burgers**3.0_pReal prm%minDipDistance = config%getFloat('cedgedipmindistance') * prm%burgers - prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_pReal !should be on by default, ToDo: change to /key/-key + prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_pReal !should be on by default, ToDo: change to /key/-type key ! expand: family => system prm%rho0 = math_expand(prm%rho0, prm%Nslip) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index d70fe68f7..be4261b03 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -151,7 +151,6 @@ subroutine plastic_kinehardening_init outputID character(len=pStringLen) :: & - structure = '',& extmsg = '' character(len=65536), dimension(:), allocatable :: & outputs @@ -187,8 +186,6 @@ subroutine plastic_kinehardening_init endif #endif - structure = config%getString('lattice_structure') - !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined prm%aTolResistance = config%getFloat('atol_resistance',defaultVal=1.0_pReal) @@ -203,28 +200,29 @@ subroutine plastic_kinehardening_init prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then - prm%Schmid = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config%getFloat('c/a',defaultVal=0.0_pReal)) - if(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%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) else - prm%nonSchmid_pos = prm%Schmid - prm%nonSchmid_neg = prm%Schmid + prm%nonSchmid_pos = prm%Schmid + prm%nonSchmid_neg = prm%Schmid endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - structure(1:3)) + config%getString('lattice_structure')) - prm%crss0 = config%getFloats('crss0', requiredShape=shape(prm%Nslip)) - prm%tau1 = config%getFloats('tau1', requiredShape=shape(prm%Nslip)) - prm%tau1_b = config%getFloats('tau1_b', requiredShape=shape(prm%Nslip)) - prm%theta0 = config%getFloats('theta0', requiredShape=shape(prm%Nslip)) - prm%theta1 = config%getFloats('theta1', requiredShape=shape(prm%Nslip)) - prm%theta0_b = config%getFloats('theta0_b', requiredShape=shape(prm%Nslip)) - prm%theta1_b = config%getFloats('theta1_b', requiredShape=shape(prm%Nslip)) + prm%crss0 = config%getFloats('crss0', requiredSize=size(prm%Nslip)) + prm%tau1 = config%getFloats('tau1', requiredSize=size(prm%Nslip)) + prm%tau1_b = config%getFloats('tau1_b', requiredSize=size(prm%Nslip)) + prm%theta0 = config%getFloats('theta0', requiredSize=size(prm%Nslip)) + prm%theta1 = config%getFloats('theta1', requiredSize=size(prm%Nslip)) + prm%theta0_b = config%getFloats('theta0_b', requiredSize=size(prm%Nslip)) + prm%theta1_b = config%getFloats('theta1_b', requiredSize=size(prm%Nslip)) prm%gdot0 = config%getFloat('gdot0') prm%n = config%getFloat('n_slip') diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 0fe0f51e8..fd40f12da 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -153,7 +153,6 @@ subroutine plastic_phenopowerlaw_init outputID character(len=pStringLen) :: & - structure = '',& extmsg = '' character(len=65536), dimension(:), allocatable :: & outputs @@ -181,8 +180,6 @@ subroutine plastic_phenopowerlaw_init stt => state(phase_plasticityInstance(p)), & config => config_phase(p)) - structure = config%getString('lattice_structure') - !-------------------------------------------------------------------------------------------------- ! optional parameters that need to be defined prm%twinB = config%getFloat('twin_b',defaultVal=1.0_pReal) @@ -204,30 +201,31 @@ subroutine plastic_phenopowerlaw_init prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& - config%getFloat('c/a',defaultVal=0.0_pReal)) - if(structure=='bcc') then - prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& + 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_pInt) + prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) else - prm%nonSchmid_pos = prm%Schmid_slip - prm%nonSchmid_neg = prm%Schmid_slip + prm%nonSchmid_pos = prm%Schmid_slip + prm%nonSchmid_neg = prm%Schmid_slip endif prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - structure(1:3)) + 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)) - prm%H_int = config%getFloats('h_int', requiredSize=size(prm%Nslip), & - defaultVal=[(0.0_pReal,i=1_pInt,size(prm%Nslip))]) + 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))]) - prm%gdot0_slip = config%getFloat('gdot0_slip') - prm%n_slip = config%getFloat('n_slip') - prm%a_slip = config%getFloat('a_slip') - prm%h0_SlipSlip = config%getFloat('h0_slipslip') + prm%gdot0_slip = config%getFloat('gdot0_slip') + prm%n_slip = config%getFloat('n_slip') + prm%a_slip = config%getFloat('a_slip') + prm%h0_SlipSlip = config%getFloat('h0_slipslip') ! expand: family => system prm%xi_slip_0 = math_expand(prm%xi_slip_0, prm%Nslip) @@ -250,12 +248,12 @@ subroutine plastic_phenopowerlaw_init prm%Ntwin = config%getInts('ntwin', defaultVal=emptyIntArray) prm%totalNtwin = sum(prm%Ntwin) twinActive: if (prm%totalNtwin > 0_pInt) then - prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,structure(1:3),& + 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_TwinTwin(prm%Ntwin,& config%getFloats('interaction_twintwin'), & - structure(1:3)) - prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,structure(1:3),& + config%getString('lattice_structure')) + prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a')) prm%xi_twin_0 = config%getFloats('tau0_twin',requiredSize=size(prm%Ntwin)) @@ -282,10 +280,10 @@ subroutine plastic_phenopowerlaw_init slipAndTwinActive: if (prm%totalNslip > 0_pInt .and. prm%totalNtwin > 0_pInt) then prm%interaction_SlipTwin = lattice_interaction_SlipTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & - structure(1:3)) + config%getString('lattice_structure')) prm%interaction_TwinSlip = lattice_interaction_TwinSlip(prm%Ntwin,prm%Nslip,& config%getFloats('interaction_twinslip'), & - structure(1:3)) + config%getString('lattice_structure')) else slipAndTwinActive 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 From e2c31bdc7c0987b61e3e736673e4fc6c0d9d6b2a Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 25 Jan 2019 14:23:52 +0100 Subject: [PATCH 272/372] [skip ci] updated version information after successful test of v2.0.2-1496-g1c4dc2e0 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index a25b1aedf..2c7fbd47e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1464-g8fabacec +v2.0.2-1496-g1c4dc2e0 From 79603be179529bcf6a0bf63aba8b2dd6cd2ad235 Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 25 Jan 2019 17:42:17 +0100 Subject: [PATCH 273/372] [skip ci] updated version information after successful test of v2.0.2-1500-g7f640896 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index a25b1aedf..f2aea9e3e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1464-g8fabacec +v2.0.2-1500-g7f640896 From bf6b365ae7b7ca34fcbb06f748fe8eda1e6ecaee Mon Sep 17 00:00:00 2001 From: Test User Date: Fri, 25 Jan 2019 20:18:03 +0100 Subject: [PATCH 274/372] [skip ci] updated version information after successful test of v2.0.2-1501-gf2882f19 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index a25b1aedf..78ecb88d7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1464-g8fabacec +v2.0.2-1501-gf2882f19 From e9c1299a305663fcf1c581f92cadfdc9624dac91 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 26 Jan 2019 09:02:44 +0100 Subject: [PATCH 275/372] requiredShape makes no sense the return value is always a 1D array, only its size might change --- src/config.f90 | 11 ++++------- src/plastic_dislotwin.f90 | 26 +++++++++++++------------- 2 files changed, 17 insertions(+), 20 deletions(-) diff --git a/src/config.f90 b/src/config.f90 index b79442e62..b184f2a6b 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -550,7 +550,7 @@ end function getString !> @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,requiredShape,requiredSize) +function getFloats(this,key,defaultVal,requiredSize) use IO, only: & IO_error, & IO_stringValue, & @@ -561,7 +561,6 @@ function getFloats(this,key,defaultVal,requiredShape,requiredSize) class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key real(pReal), dimension(:), intent(in), optional :: defaultVal - integer(pInt), dimension(:), intent(in), optional :: requiredShape ! not useful (is always 1D array) integer(pInt), intent(in), optional :: requiredSize type(tPartitionedStringList), pointer :: item integer(pInt) :: i @@ -601,7 +600,7 @@ end function getFloats !> @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,requiredShape,requiredSize) +function getInts(this,key,defaultVal,requiredSize) use IO, only: & IO_error, & IO_stringValue, & @@ -611,8 +610,7 @@ function getInts(this,key,defaultVal,requiredShape,requiredSize) integer(pInt), dimension(:), allocatable :: getInts class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key - integer(pInt), dimension(:), intent(in), optional :: defaultVal, & - requiredShape ! not useful (is always 1D array) + integer(pInt), dimension(:), intent(in), optional :: defaultVal integer(pInt), intent(in), optional :: requiredSize type(tPartitionedStringList), pointer :: item integer(pInt) :: i @@ -653,7 +651,7 @@ end function getInts !! 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,requiredShape,raw) +function getStrings(this,key,defaultVal,raw) use IO, only: & IO_error, & IO_StringValue @@ -663,7 +661,6 @@ function getStrings(this,key,defaultVal,requiredShape,raw) class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key character(len=65536),dimension(:), intent(in), optional :: defaultVal - integer(pInt), dimension(:), intent(in), optional :: requiredShape logical, intent(in), optional :: raw type(tPartitionedStringList), pointer :: item character(len=65536) :: str diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 0c56e6ba5..141837d86 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -312,17 +312,17 @@ subroutine plastic_dislotwin_init config%getFloats('interaction_slipslip'), & structure(1:3)) - prm%rho0 = config%getFloats('rhoedge0', requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_0 - prm%rhoDip0 = config%getFloats('rhoedgedip0',requiredShape=shape(prm%Nslip)) !ToDo: rename to rho_dip_0 - prm%v0 = config%getFloats('v0', requiredShape=shape(prm%Nslip)) - prm%burgers_slip = config%getFloats('slipburgers',requiredShape=shape(prm%Nslip)) - prm%Qedge = config%getFloats('qedge', requiredShape=shape(prm%Nslip)) !ToDo: rename (ask Karo) - prm%CLambdaSlip = config%getFloats('clambdaslip',requiredShape=shape(prm%Nslip)) - prm%p = config%getFloats('p_slip', requiredShape=shape(prm%Nslip)) - prm%q = config%getFloats('q_slip', requiredShape=shape(prm%Nslip)) - prm%B = config%getFloats('b', requiredShape=shape(prm%Nslip), & + prm%rho0 = config%getFloats('rhoedge0', requiredSize=size(prm%Nslip)) !ToDo: rename to rho_0 + prm%rhoDip0 = config%getFloats('rhoedgedip0',requiredSize=size(prm%Nslip)) !ToDo: rename to rho_dip_0 + prm%v0 = config%getFloats('v0', requiredSize=size(prm%Nslip)) + prm%burgers_slip = config%getFloats('slipburgers',requiredSize=size(prm%Nslip)) + prm%Qedge = config%getFloats('qedge', requiredSize=size(prm%Nslip)) !ToDo: rename (ask Karo) + prm%CLambdaSlip = config%getFloats('clambdaslip',requiredSize=size(prm%Nslip)) + prm%p = config%getFloats('p_slip', requiredSize=size(prm%Nslip)) + prm%q = config%getFloats('q_slip', requiredSize=size(prm%Nslip)) + prm%B = config%getFloats('b', requiredSize=size(prm%Nslip), & defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) - prm%tau_peierls = config%getFloats('tau_peierls',requiredShape=shape(prm%Nslip), & + prm%tau_peierls = config%getFloats('tau_peierls',requiredSize=size(prm%Nslip), & defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) ! Deprecated prm%CEdgeDipMinDistance = config%getFloat('cedgedipmindistance') @@ -366,9 +366,9 @@ subroutine plastic_dislotwin_init config%getFloats('interaction_twintwin'), & structure(1:3)) - prm%burgers_twin = config%getFloats('twinburgers') - prm%twinsize = config%getFloats('twinsize') - prm%r = config%getFloats('r_twin') + prm%burgers_twin = config%getFloats('twinburgers', requiredSize=size(prm%Ntwin)) + prm%twinsize = config%getFloats('twinsize', requiredSize=size(prm%Ntwin)) + prm%r = config%getFloats('r_twin', requiredSize=size(prm%Ntwin)) prm%xc_twin = config%getFloat('xc_twin') prm%L0_twin = config%getFloat('l0_twin') From 012aa4c697e6f4a072b0744a6f26f599f698122c Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 26 Jan 2019 11:22:23 +0100 Subject: [PATCH 276/372] [skip ci] updated version information after successful test of v2.0.2-1516-gffd29bdc --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 2c7fbd47e..6dee49c94 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1496-g1c4dc2e0 +v2.0.2-1516-gffd29bdc From 3b5a6b2877695a2bdd2aa0c3b1ac2121f768d5fd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 08:17:08 +0100 Subject: [PATCH 277/372] have internal functions at the end of the module --- src/plastic_dislotwin.f90 | 419 +++++++++++++++++++------------------- 1 file changed, 210 insertions(+), 209 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 141837d86..f61d04187 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -231,7 +231,7 @@ subroutine plastic_dislotwin_init implicit none integer(pInt) :: Ninstance,& f,j,i,k,o,p, & - offset_slip, index_myFamily, index_otherFamily, & + offset_slip, & startIndex, endIndex, outputSize integer(pInt) :: sizeState, sizeDotState integer(pInt) :: NipcMyPhase @@ -303,9 +303,9 @@ subroutine plastic_dislotwin_init if(prm%fccTwinTransNucleation) & prm%fcc_twinNucleationSlipPair = lattice_fcc_twinNucleationSlipPair - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,structure(1:3),& + prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%forestProjection = lattice_forestProjection (prm%Nslip,structure(1:3),& + prm%forestProjection = lattice_forestProjection (prm%Nslip,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & @@ -360,11 +360,11 @@ subroutine plastic_dislotwin_init prm%Ntwin = config%getInts('ntwin', defaultVal=emptyIntArray) prm%totalNtwin = sum(prm%Ntwin) if (prm%totalNtwin > 0_pInt) then - prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,structure(1:3),& + 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_TwinTwin(prm%Ntwin,& config%getFloats('interaction_twintwin'), & - structure(1:3)) + config%getString('lattice_structure')) prm%burgers_twin = config%getFloats('twinburgers', requiredSize=size(prm%Ntwin)) prm%twinsize = config%getFloats('twinsize', requiredSize=size(prm%Ntwin)) @@ -376,10 +376,10 @@ subroutine plastic_dislotwin_init prm%Cthresholdtwin = config%getFloat('cthresholdtwin', defaultVal=0.0_pReal) prm%Cmfptwin = config%getFloat('cmfptwin', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%shear_twin = lattice_characteristicShear_Twin(prm%Ntwin,structure(1:3),& + prm%shear_twin = lattice_characteristicShear_Twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%C66_twin = lattice_C66_twin(prm%Ntwin,prm%C66,structure(1:3),& + prm%C66_twin = lattice_C66_twin(prm%Ntwin,prm%C66,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) if (.not. prm%fccTwinTransNucleation) then @@ -415,7 +415,7 @@ subroutine plastic_dislotwin_init prm%interaction_TransTrans = lattice_interaction_TransTrans(prm%Ntrans,& config%getFloats('interaction_transtrans'), & - structure(1:3)) + config%getString('lattice_structure')) prm%C66_trans = lattice_C66_trans(prm%Ntrans,prm%C66, & config%getString('trans_lattice_structure'), & @@ -1165,6 +1165,208 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) end subroutine plastic_dislotwin_dotState +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postResults) + use prec, only: & + tol_math_check, & + dEq0 + use math, only: & + PI, & + math_mul33xx33, & + math_Mandel6to33 + + implicit none + real(pReal), dimension(3,3),intent(in) :: & + Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + instance, & + of + + real(pReal), dimension(sum(plastic_dislotwin_sizePostResult(:,instance))) :: & + postResults + + integer(pInt) :: & + o,c,j,& + s1,s2 + real(pReal) :: sumf_twin,tau,StressRatio_p,StressRatio_pminus1,BoltzmannRatio,DotGamma0,StressRatio_r,Ndot0_twin,dgdot_dtauslip, & + stressRatio + real(pReal), dimension(param(instance)%totalNslip) :: & + gdot_slip + + type(tParameters) :: prm + type(tDislotwinState) :: stt + type(tDislotwinMicrostructure) :: mse + + + associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) + + sumf_twin = sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) + + c = 0_pInt + postResults = 0.0_pReal + do o = 1_pInt,size(prm%outputID) + select case(prm%outputID(o)) + + case (edge_density_ID) + postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdge(1_pInt:prm%totalNslip,of) + c = c + prm%totalNslip + case (dipole_density_ID) + postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) + c = c + prm%totalNslip + case (shear_rate_slip_ID) + call kinetics_slip(prm,stt,mse,of,Mp,temperature,postResults(c+1:c+prm%totalNslip)) + c = c + prm%totalNslip + case (accumulated_shear_slip_ID) + postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip,of) + c = c + prm%totalNslip + case (mfp_slip_ID) + postResults(c+1_pInt:c+prm%totalNslip) = mse%mfp_slip(1_pInt:prm%totalNslip,of) + c = c + prm%totalNslip + case (resolved_stress_slip_ID) + do j = 1_pInt, prm%totalNslip + postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) + enddo + c = c + prm%totalNslip + case (threshold_stress_slip_ID) + postResults(c+1_pInt:c+prm%totalNslip) = mse%threshold_stress_slip(1_pInt:prm%totalNslip,of) + c = c + prm%totalNslip + case (edge_dipole_distance_ID) + do j = 1_pInt, prm%totalNslip + postResults(c+j) = (3.0_pReal*prm%mu*prm%burgers_slip(j)) & + / (16.0_pReal*PI*abs(math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)))) + postResults(c+j)=min(postResults(c+j),mse%mfp_slip(j,of)) + ! postResults(c+j)=max(postResults(c+j),& + ! plasticState(ph)%state(4*ns+2*nt+2*nr+j, of)) + enddo + c = c + prm%totalNslip + ! case (resolved_stress_shearband_ID) + ! do j = 1_pInt,6_pInt ! loop over all shearband families + ! postResults(c+j) = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) + ! enddo + ! c = c + 6_pInt + ! case (shear_rate_shearband_ID) + ! do j = 1_pInt,6_pInt ! loop over all shearbands + ! tau = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) + ! if (abs(tau) < tol_math_check) then + ! StressRatio_p = 0.0_pReal + ! StressRatio_pminus1 = 0.0_pReal + ! else + ! StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand + ! StressRatio_pminus1 = (abs(tau)/prm%sbResistance)**(prm%pShearBand-1.0_pReal) + ! endif + ! BoltzmannRatio = prm%sbQedge/(kB*Temperature) + ! DotGamma0 = prm%sbVelocity + ! postResults(c+j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**prm%qShearBand)*& + ! sign(1.0_pReal,tau) + ! enddo + ! c = c + 6_pInt + case (twin_fraction_ID) + postResults(c+1_pInt:c+prm%totalNtwin) = stt%twinFraction(1_pInt:prm%totalNtwin,of) + c = c + prm%totalNtwin + case (shear_rate_twin_ID) + do j = 1_pInt, prm%totalNslip + tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) + if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then + StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& + (prm%SolidSolutionStrength+& + prm%tau_peierls(j)))& + **prm%p(j) + StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& + (prm%SolidSolutionStrength+& + prm%tau_peierls(j)))& + **(prm%p(j)-1.0_pReal) + BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) + DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) + + gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + prm%q(j))*sign(1.0_pReal,tau) + else + gdot_slip(j) = 0.0_pReal + endif + enddo + + do j = 1_pInt, prm%totalNtwin + tau = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) + + if ( tau > 0.0_pReal ) then + isFCCtwin: if (prm%fccTwinTransNucleation) then + s1=prm%fcc_twinNucleationSlipPair(1,j) + s2=prm%fcc_twinNucleationSlipPair(2,j) + if (tau < mse%tau_r_twin(j,of)) then + Ndot0_twin=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& + (prm%L0_twin* prm%burgers_slip(j))*& + (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)* (mse%tau_r_twin(j,of)-tau))) + else + Ndot0_twin=0.0_pReal + end if + else isFCCtwin + Ndot0_twin=prm%Ndot0_twin(j) + endif isFCCtwin + StressRatio_r = (mse%threshold_stress_twin(j,of)/tau) **prm%r(j) + postResults(c+j) = (prm%MaxTwinFraction-sumf_twin)*prm%shear_twin(j) & + * mse%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) + endif + enddo + c = c + prm%totalNtwin + case (accumulated_shear_twin_ID) + postResults(c+1_pInt:c+prm%totalNtwin) = stt%accshear_twin(1_pInt:prm%totalNtwin,of) + c = c + prm%totalNtwin + case (mfp_twin_ID) + postResults(c+1_pInt:c+prm%totalNtwin) = mse%mfp_twin(1_pInt:prm%totalNtwin,of) + c = c + prm%totalNtwin + case (resolved_stress_twin_ID) + do j = 1_pInt, prm%totalNtwin + postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) + enddo + c = c + prm%totalNtwin + case (threshold_stress_twin_ID) + postResults(c+1_pInt:c+prm%totalNtwin) = mse%threshold_stress_twin(1_pInt:prm%totalNtwin,of) + c = c + prm%totalNtwin + case (stress_exponent_ID) + do j = 1_pInt, prm%totalNslip + tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) + if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then + StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& + (prm%SolidSolutionStrength+& + prm%tau_peierls(j)))& + **prm%p(j) + StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& + (prm%SolidSolutionStrength+& + prm%tau_peierls(j)))& + **(prm%p(j)-1.0_pReal) + BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) + DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) + + gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + prm%q(j))*sign(1.0_pReal,tau) + + dgdot_dtauslip = abs(gdot_slip(j))*BoltzmannRatio*prm%p(j) *prm%q(j)/& + (prm%SolidSolutionStrength+ prm%tau_peierls(j))*& + StressRatio_pminus1*(1-StressRatio_p)**(prm%q(j)-1.0_pReal) + else + gdot_slip(j) = 0.0_pReal + dgdot_dtauslip = 0.0_pReal + endif + postResults(c+j) = merge(0.0_pReal,(tau/gdot_slip(j))*dgdot_dtauslip,dEq0(gdot_slip(j))) + enddo + c = c + prm%totalNslip + case (stress_trans_fraction_ID) + postResults(c+1_pInt:c+prm%totalNtrans) = stt%stressTransFraction(1_pInt:prm%totalNtrans,of) + c = c + prm%totalNtrans + case (strain_trans_fraction_ID) + postResults(c+1_pInt:c+prm%totalNtrans) = stt%strainTransFraction(1_pInt:prm%totalNtrans,of) + c = c + prm%totalNtrans + end select + enddo + end associate +end function plastic_dislotwin_postResults + + !-------------------------------------------------------------------------------------------------- !> @brief calculates shear rates on slip systems !-------------------------------------------------------------------------------------------------- @@ -1395,205 +1597,4 @@ pure subroutine kinetics_trans(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_tran ! end subroutine kinetics_trans -!-------------------------------------------------------------------------------------------------- -!> @brief return array of constitutive results -!-------------------------------------------------------------------------------------------------- -function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postResults) - use prec, only: & - tol_math_check, & - dEq0 - use math, only: & - PI, & - math_mul33xx33, & - math_Mandel6to33 - - implicit none - real(pReal), dimension(3,3),intent(in) :: & - Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation - real(pReal), intent(in) :: & - temperature !< temperature at integration point - integer(pInt), intent(in) :: & - instance, & - of - - real(pReal), dimension(sum(plastic_dislotwin_sizePostResult(:,instance))) :: & - postResults - - integer(pInt) :: & - o,c,j,& - s1,s2 - real(pReal) :: sumf_twin,tau,StressRatio_p,StressRatio_pminus1,BoltzmannRatio,DotGamma0,StressRatio_r,Ndot0_twin,dgdot_dtauslip, & - stressRatio - real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip - - type(tParameters) :: prm - type(tDislotwinState) :: stt - type(tDislotwinMicrostructure) :: mse - - - associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) - - sumf_twin = sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) - - c = 0_pInt - postResults = 0.0_pReal - do o = 1_pInt,size(prm%outputID) - select case(prm%outputID(o)) - - case (edge_density_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdge(1_pInt:prm%totalNslip,of) - c = c + prm%totalNslip - case (dipole_density_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) - c = c + prm%totalNslip - case (shear_rate_slip_ID) - call kinetics_slip(prm,stt,mse,of,Mp,temperature,postResults(c+1:c+prm%totalNslip)) - c = c + prm%totalNslip - case (accumulated_shear_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip,of) - c = c + prm%totalNslip - case (mfp_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = mse%mfp_slip(1_pInt:prm%totalNslip,of) - c = c + prm%totalNslip - case (resolved_stress_slip_ID) - do j = 1_pInt, prm%totalNslip - postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) - enddo - c = c + prm%totalNslip - case (threshold_stress_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = mse%threshold_stress_slip(1_pInt:prm%totalNslip,of) - c = c + prm%totalNslip - case (edge_dipole_distance_ID) - do j = 1_pInt, prm%totalNslip - postResults(c+j) = (3.0_pReal*prm%mu*prm%burgers_slip(j)) & - / (16.0_pReal*PI*abs(math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)))) - postResults(c+j)=min(postResults(c+j),mse%mfp_slip(j,of)) - ! postResults(c+j)=max(postResults(c+j),& - ! plasticState(ph)%state(4*ns+2*nt+2*nr+j, of)) - enddo - c = c + prm%totalNslip - ! case (resolved_stress_shearband_ID) - ! do j = 1_pInt,6_pInt ! loop over all shearband families - ! postResults(c+j) = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) - ! enddo - ! c = c + 6_pInt - ! case (shear_rate_shearband_ID) - ! do j = 1_pInt,6_pInt ! loop over all shearbands - ! tau = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) - ! if (abs(tau) < tol_math_check) then - ! StressRatio_p = 0.0_pReal - ! StressRatio_pminus1 = 0.0_pReal - ! else - ! StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand - ! StressRatio_pminus1 = (abs(tau)/prm%sbResistance)**(prm%pShearBand-1.0_pReal) - ! endif - ! BoltzmannRatio = prm%sbQedge/(kB*Temperature) - ! DotGamma0 = prm%sbVelocity - ! postResults(c+j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**prm%qShearBand)*& - ! sign(1.0_pReal,tau) - ! enddo - ! c = c + 6_pInt - case (twin_fraction_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%twinFraction(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (shear_rate_twin_ID) - do j = 1_pInt, prm%totalNslip - tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) - if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then - StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **prm%p(j) - StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **(prm%p(j)-1.0_pReal) - BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) - DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) - - gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& - prm%q(j))*sign(1.0_pReal,tau) - else - gdot_slip(j) = 0.0_pReal - endif - enddo - - do j = 1_pInt, prm%totalNtwin - tau = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) - - if ( tau > 0.0_pReal ) then - isFCCtwin: if (prm%fccTwinTransNucleation) then - s1=prm%fcc_twinNucleationSlipPair(1,j) - s2=prm%fcc_twinNucleationSlipPair(2,j) - if (tau < mse%tau_r_twin(j,of)) then - Ndot0_twin=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_twin* prm%burgers_slip(j))*& - (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)* (mse%tau_r_twin(j,of)-tau))) - else - Ndot0_twin=0.0_pReal - end if - else isFCCtwin - Ndot0_twin=prm%Ndot0_twin(j) - endif isFCCtwin - StressRatio_r = (mse%threshold_stress_twin(j,of)/tau) **prm%r(j) - postResults(c+j) = (prm%MaxTwinFraction-sumf_twin)*prm%shear_twin(j) & - * mse%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) - endif - enddo - c = c + prm%totalNtwin - case (accumulated_shear_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%accshear_twin(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (mfp_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = mse%mfp_twin(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (resolved_stress_twin_ID) - do j = 1_pInt, prm%totalNtwin - postResults(c+j) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) - enddo - c = c + prm%totalNtwin - case (threshold_stress_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = mse%threshold_stress_twin(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (stress_exponent_ID) - do j = 1_pInt, prm%totalNslip - tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) - if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then - StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **prm%p(j) - StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **(prm%p(j)-1.0_pReal) - BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) - DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) - - gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& - prm%q(j))*sign(1.0_pReal,tau) - - dgdot_dtauslip = abs(gdot_slip(j))*BoltzmannRatio*prm%p(j) *prm%q(j)/& - (prm%SolidSolutionStrength+ prm%tau_peierls(j))*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q(j)-1.0_pReal) - else - gdot_slip(j) = 0.0_pReal - dgdot_dtauslip = 0.0_pReal - endif - postResults(c+j) = merge(0.0_pReal,(tau/gdot_slip(j))*dgdot_dtauslip,dEq0(gdot_slip(j))) - enddo - c = c + prm%totalNslip - case (stress_trans_fraction_ID) - postResults(c+1_pInt:c+prm%totalNtrans) = stt%stressTransFraction(1_pInt:prm%totalNtrans,of) - c = c + prm%totalNtrans - case (strain_trans_fraction_ID) - postResults(c+1_pInt:c+prm%totalNtrans) = stt%strainTransFraction(1_pInt:prm%totalNtrans,of) - c = c + prm%totalNtrans - end select - enddo - end associate -end function plastic_dislotwin_postResults - end module plastic_dislotwin From 4b2da52e87a95bd1fde56923c3f7e3f9f85b4d7c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 08:35:07 +0100 Subject: [PATCH 278/372] following example of disloUCLA --- src/constitutive.f90 | 6 +- src/plastic_dislotwin.f90 | 274 ++++++++++++++++++-------------------- 2 files changed, 134 insertions(+), 146 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 299ed1c04..374f5ddee 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -365,7 +365,7 @@ subroutine constitutive_microstructure(orientations, Fe, Fp, ipc, ip, el) use plastic_nonlocal, only: & plastic_nonlocal_microstructure use plastic_dislotwin, only: & - plastic_dislotwin_microstructure + plastic_dislotwin_dependentState use plastic_disloUCLA, only: & plastic_disloUCLA_dependentState @@ -389,7 +389,9 @@ subroutine constitutive_microstructure(orientations, Fe, Fp, ipc, ip, el) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) case (PLASTICITY_DISLOTWIN_ID) plasticityType - call plastic_dislotwin_microstructure(temperature(ho)%p(tme),ipc,ip,el) + of = phasememberAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + call plastic_dislotwin_dependentState(temperature(ho)%p(tme),instance,of) case (PLASTICITY_DISLOUCLA_ID) plasticityType of = phasememberAt(ipc,ip,el) instance = phase_plasticityInstance(material_phase(ipc,ip,el)) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index f61d04187..29679233d 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -177,7 +177,7 @@ module plastic_dislotwin public :: & plastic_dislotwin_init, & plastic_dislotwin_homogenizedC, & - plastic_dislotwin_microstructure, & + plastic_dislotwin_dependentState, & plastic_dislotwin_LpAndItsTangent, & plastic_dislotwin_dotState, & plastic_dislotwin_postResults @@ -230,7 +230,7 @@ subroutine plastic_dislotwin_init implicit none integer(pInt) :: Ninstance,& - f,j,i,k,o,p, & + i,p, & offset_slip, & startIndex, endIndex, outputSize integer(pInt) :: sizeState, sizeDotState @@ -245,7 +245,6 @@ subroutine plastic_dislotwin_init outputID !< ID of each post result output character(len=pStringLen) :: & - structure = '',& extmsg = '' character(len=65536), dimension(:), allocatable :: & outputs @@ -289,8 +288,6 @@ subroutine plastic_dislotwin_init prm%nu = lattice_nu(p) prm%C66 = lattice_C66(1:6,1:6,p) - structure = config%getString('lattice_structure') - !-------------------------------------------------------------------------------------------------- ! slip related parameters @@ -310,7 +307,7 @@ subroutine plastic_dislotwin_init prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - structure(1:3)) + config%getString('lattice_structure')) prm%rho0 = config%getFloats('rhoedge0', requiredSize=size(prm%Nslip)) !ToDo: rename to rho_0 prm%rhoDip0 = config%getFloats('rhoedgedip0',requiredSize=size(prm%Nslip)) !ToDo: rename to rho_dip_0 @@ -451,17 +448,17 @@ subroutine plastic_dislotwin_init if (prm%totalNslip > 0_pInt .and. prm%totalNtwin > 0_pInt) then prm%interaction_SlipTwin = lattice_interaction_SlipTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & - structure(1:3)) + config%getString('lattice_structure')) prm%interaction_TwinSlip = lattice_interaction_TwinSlip(prm%Ntwin,prm%Nslip,& config%getFloats('interaction_twinslip'), & - structure(1:3)) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%totalNtwin > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntwin is [6,6] endif if (prm%totalNslip > 0_pInt .and. prm%totalNtrans > 0_pInt) then prm%interaction_SlipTrans = lattice_interaction_SlipTrans(prm%Nslip,prm%Ntrans,& config%getFloats('interaction_sliptrans'), & - structure(1:3)) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] endif @@ -735,133 +732,6 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) end function plastic_dislotwin_homogenizedC -!-------------------------------------------------------------------------------------------------- -!> @brief calculates derived quantities from state -!-------------------------------------------------------------------------------------------------- -subroutine plastic_dislotwin_microstructure(temperature,ipc,ip,el) - use math, only: & - PI - use material, only: & - material_phase, & - phase_plasticityInstance, & - phasememberAt - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), intent(in) :: & - temperature !< temperature at IP - - integer(pInt) :: & - i, & - of - real(pReal) :: & - sumf_twin,SFE,sumf_trans - real(pReal), dimension(:), allocatable :: & - x0, & - fOverStacksize, & - ftransOverLamellarSize - - of = phasememberAt(ipc,ip,el) - - associate(prm => param(phase_plasticityInstance(material_phase(ipc,ip,el))),& - stt => state(phase_plasticityInstance(material_phase(ipc,ip,el))),& - mse => microstructure(phase_plasticityInstance(material_phase(ipc,ip,el)))) - - sumf_twin = sum(stt%twinFraction(1:prm%totalNtwin,of)) - sumf_trans = sum(stt%stressTransFraction(1:prm%totalNtrans,of)) & - + sum(stt%strainTransFraction(1:prm%totalNtrans,of)) - - sfe = prm%SFE_0K + prm%dSFE_dT * Temperature - - !* rescaled volume fraction for topology - fOverStacksize = stt%twinFraction(1_pInt:prm%totalNtwin,of)/prm%twinsize !ToDo: this is per system - ftransOverLamellarSize = sumf_trans/prm%lamellarsizePerTransSystem !ToDo: But this not ... - !Todo: Physically ok, but naming could be adjusted - - - !* 1/mean free distance between 2 forest dislocations seen by a moving dislocation - forall (i = 1_pInt:prm%totalNslip) & - mse%invLambdaSlip(i,of) = & - sqrt(dot_product((stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of)),& - prm%forestProjection(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) - - !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation - !$OMP CRITICAL (evilmatmul) - if (prm%totalNtwin > 0_pInt .and. prm%totalNslip > 0_pInt) & - mse%invLambdaSlipTwin(1_pInt:prm%totalNslip,of) = & - matmul(prm%interaction_SlipTwin,fOverStacksize)/(1.0_pReal-sumf_twin) - - !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin - - !ToDo: needed? if (prm%totalNtwin > 0_pInt) & - mse%invLambdaTwin(1_pInt:prm%totalNtwin,of) = & - matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) - - - !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation - if (prm%totalNtrans > 0_pInt .and. prm%totalNslip > 0_pInt) & - mse%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & ! ToDo: does not work if Ntrans is not 12 - matmul(prm%interaction_SlipTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) - - !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) - !ToDo: needed? if (prm%totalNtrans > 0_pInt) & - - mse%invLambdaTrans(1_pInt:prm%totalNtrans,of) = & - matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) - !$OMP END CRITICAL (evilmatmul) - - !* mean free path between 2 obstacles seen by a moving dislocation - do i = 1_pInt,prm%totalNslip - if ((prm%totalNtwin > 0_pInt) .or. (prm%totalNtrans > 0_pInt)) then ! ToDo: This is too simplified - mse%mfp_slip(i,of) = & - prm%GrainSize/(1.0_pReal+prm%GrainSize*& - (mse%invLambdaSlip(i,of) + mse%invLambdaSlipTwin(i,of) + mse%invLambdaSlipTrans(i,of))) - else - mse%mfp_slip(i,of) = & - prm%GrainSize/& - (1.0_pReal+prm%GrainSize*(mse%invLambdaSlip(i,of))) !!!!!! correct? - endif - enddo - - !* mean free path between 2 obstacles seen by a growing twin/martensite - mse%mfp_twin(:,of) = prm%Cmfptwin*prm%GrainSize/ (1.0_pReal+prm%GrainSize*mse%invLambdaTwin(:,of)) - mse%mfp_trans(:,of) = prm%Cmfptrans*prm%GrainSize/(1.0_pReal+prm%GrainSize*mse%invLambdaTrans(:,of)) - - !* threshold stress for dislocation motion - forall (i = 1_pInt:prm%totalNslip) mse%threshold_stress_slip(i,of) = & - prm%mu*prm%burgers_slip(i)*& - sqrt(dot_product(stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of),& - prm%interaction_SlipSlip(i,1:prm%totalNslip))) - - !* threshold stress for growing twin/martensite - if(prm%totalNtwin == prm%totalNslip) & - mse%threshold_stress_twin(:,of) = prm%Cthresholdtwin* & - (sfe/(3.0_pReal*prm%burgers_twin)+ 3.0_pReal*prm%burgers_twin*prm%mu/ & - (prm%L0_twin*prm%burgers_slip)) ! slip burgers here correct? - if(prm%totalNtrans == prm%totalNslip) & - mse%threshold_stress_trans(:,of) = prm%Cthresholdtrans* & - (sfe/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& - (prm%L0_trans*prm%burgers_slip) + prm%transStackHeight*prm%deltaG/ (3.0_pReal*prm%burgers_trans) ) - - ! final volume after growth - mse%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*mse%mfp_twin(:,of)**2.0_pReal - mse%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsizePerTransSystem*mse%mfp_trans(:,of)**2.0_pReal - - !* equilibrium separation of partial dislocations (twin) - x0 = prm%mu*prm%burgers_twin**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) - mse%tau_r_twin(:,of) = prm%mu*prm%burgers_twin/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0) - - !* equilibrium separation of partial dislocations (trans) - x0 = prm%mu*prm%burgers_trans**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) - mse%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) - -end associate -end subroutine plastic_dislotwin_microstructure - - !-------------------------------------------------------------------------------------------------- !> @brief calculates plastic velocity gradient and its tangent !-------------------------------------------------------------------------------------------------- @@ -885,7 +755,7 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, integer(pInt) :: i,k,l,m,n,s1,s2 real(pReal) :: f_unrotated,StressRatio_p,& - StressRatio_r,BoltzmannRatio,Ndot0_twin,stressRatio, & + BoltzmannRatio, & Ndot0_trans,StressRatio_s, & dgdot_dtau, & tau @@ -1039,9 +909,9 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) of integer(pInt) :: i,s1,s2 - real(pReal) :: f_unrotated,StressRatio_p,BoltzmannRatio,& - EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,StressRatio_r,Ndot0_twin,stressRatio,& - Ndot0_trans,StressRatio_s,EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & + real(pReal) :: f_unrotated,& + EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,Ndot0_twin,& + Ndot0_trans,StressRatio_r,StressRatio_s,EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & DotRhoDipFormation,DotRhoMultiplication,DotRhoEdgeEdgeAnnihilation, & tau real(pReal), dimension(plasticState(instance)%Nslip) :: & @@ -1165,6 +1035,126 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) end subroutine plastic_dislotwin_dotState +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_dependentState(temperature,instance,of) + use math, only: & + PI + + implicit none + integer(pInt), intent(in) :: & + instance, & !< component-ID of integration point + of + real(pReal), intent(in) :: & + temperature !< temperature at IP + + integer(pInt) :: & + i + real(pReal) :: & + sumf_twin,SFE,sumf_trans + real(pReal), dimension(:), allocatable :: & + x0, & + fOverStacksize, & + ftransOverLamellarSize + + + associate(prm => param(instance),& + stt => state(instance),& + mse => microstructure(instance)) + + sumf_twin = sum(stt%twinFraction(1:prm%totalNtwin,of)) + sumf_trans = sum(stt%stressTransFraction(1:prm%totalNtrans,of)) & + + sum(stt%strainTransFraction(1:prm%totalNtrans,of)) + + sfe = prm%SFE_0K + prm%dSFE_dT * Temperature + + !* rescaled volume fraction for topology + fOverStacksize = stt%twinFraction(1_pInt:prm%totalNtwin,of)/prm%twinsize !ToDo: this is per system + ftransOverLamellarSize = sumf_trans/prm%lamellarsizePerTransSystem !ToDo: But this not ... + !Todo: Physically ok, but naming could be adjusted + + + !* 1/mean free distance between 2 forest dislocations seen by a moving dislocation + forall (i = 1_pInt:prm%totalNslip) & + mse%invLambdaSlip(i,of) = & + sqrt(dot_product((stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of)),& + prm%forestProjection(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) + + !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation + !$OMP CRITICAL (evilmatmul) + if (prm%totalNtwin > 0_pInt .and. prm%totalNslip > 0_pInt) & + mse%invLambdaSlipTwin(1_pInt:prm%totalNslip,of) = & + matmul(prm%interaction_SlipTwin,fOverStacksize)/(1.0_pReal-sumf_twin) + + !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin + + !ToDo: needed? if (prm%totalNtwin > 0_pInt) & + mse%invLambdaTwin(1_pInt:prm%totalNtwin,of) = & + matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) + + + !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation + if (prm%totalNtrans > 0_pInt .and. prm%totalNslip > 0_pInt) & + mse%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & ! ToDo: does not work if Ntrans is not 12 + matmul(prm%interaction_SlipTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) + + !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) + !ToDo: needed? if (prm%totalNtrans > 0_pInt) & + + mse%invLambdaTrans(1_pInt:prm%totalNtrans,of) = & + matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) + !$OMP END CRITICAL (evilmatmul) + + !* mean free path between 2 obstacles seen by a moving dislocation + do i = 1_pInt,prm%totalNslip + if ((prm%totalNtwin > 0_pInt) .or. (prm%totalNtrans > 0_pInt)) then ! ToDo: This is too simplified + mse%mfp_slip(i,of) = & + prm%GrainSize/(1.0_pReal+prm%GrainSize*& + (mse%invLambdaSlip(i,of) + mse%invLambdaSlipTwin(i,of) + mse%invLambdaSlipTrans(i,of))) + else + mse%mfp_slip(i,of) = & + prm%GrainSize/& + (1.0_pReal+prm%GrainSize*(mse%invLambdaSlip(i,of))) !!!!!! correct? + endif + enddo + + !* mean free path between 2 obstacles seen by a growing twin/martensite + mse%mfp_twin(:,of) = prm%Cmfptwin*prm%GrainSize/ (1.0_pReal+prm%GrainSize*mse%invLambdaTwin(:,of)) + mse%mfp_trans(:,of) = prm%Cmfptrans*prm%GrainSize/(1.0_pReal+prm%GrainSize*mse%invLambdaTrans(:,of)) + + !* threshold stress for dislocation motion + forall (i = 1_pInt:prm%totalNslip) mse%threshold_stress_slip(i,of) = & + prm%mu*prm%burgers_slip(i)*& + sqrt(dot_product(stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of),& + prm%interaction_SlipSlip(i,1:prm%totalNslip))) + + !* threshold stress for growing twin/martensite + if(prm%totalNtwin == prm%totalNslip) & + mse%threshold_stress_twin(:,of) = prm%Cthresholdtwin* & + (sfe/(3.0_pReal*prm%burgers_twin)+ 3.0_pReal*prm%burgers_twin*prm%mu/ & + (prm%L0_twin*prm%burgers_slip)) ! slip burgers here correct? + if(prm%totalNtrans == prm%totalNslip) & + mse%threshold_stress_trans(:,of) = prm%Cthresholdtrans* & + (sfe/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& + (prm%L0_trans*prm%burgers_slip) + prm%transStackHeight*prm%deltaG/ (3.0_pReal*prm%burgers_trans) ) + + ! final volume after growth + mse%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*mse%mfp_twin(:,of)**2.0_pReal + mse%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsizePerTransSystem*mse%mfp_trans(:,of)**2.0_pReal + + !* equilibrium separation of partial dislocations (twin) + x0 = prm%mu*prm%burgers_twin**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) + mse%tau_r_twin(:,of) = prm%mu*prm%burgers_twin/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0) + + !* equilibrium separation of partial dislocations (trans) + x0 = prm%mu*prm%burgers_trans**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) + mse%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) + +end associate +end subroutine plastic_dislotwin_dependentState + + !-------------------------------------------------------------------------------------------------- !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- @@ -1197,10 +1187,6 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip - type(tParameters) :: prm - type(tDislotwinState) :: stt - type(tDislotwinMicrostructure) :: mse - associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) From fc9e80b3c29dfb77dcfcc8cf5151c93ef260e468 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 10:48:27 +0100 Subject: [PATCH 279/372] using real name, not compatibility aliases --- src/constitutive.f90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 374f5ddee..a0d7147a6 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -411,9 +411,9 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e pReal use math, only: & math_mul33x33, & - math_Mandel6to33, & - math_Mandel33to6, & - math_Plain99to3333 + math_6toSym33, & + math_sym33to6, & + math_99to3333 use material, only: & phasememberAt, & phase_plasticity, & @@ -472,7 +472,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - S = math_Mandel6to33(S6) + S = math_6toSym33(S6) Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -497,9 +497,9 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, S6, Fi, ipc, ip, e call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMp, Mp,instance,of) case (PLASTICITY_NONLOCAL_ID) plasticityType - call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp99, math_Mandel33to6(Mp), & + call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp99, math_sym33to6(Mp), & temperature(ho)%p(tme),ip,el) - dLp_dMp = math_Plain99to3333(dLp_dMp99) ! ToDo: We revert here the last statement in plastic_xx_LpAndItsTanget + dLp_dMp = math_99to3333(dLp_dMp99) ! ToDo: We revert here the last statement in plastic_xx_LpAndItsTanget case (PLASTICITY_DISLOTWIN_ID) plasticityType of = phasememberAt(ipc,ip,el) @@ -542,7 +542,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e math_inv33, & math_det33, & math_mul33x33, & - math_Mandel6to33 + math_6toSym33 use material, only: & phasememberAt, & phase_plasticity, & @@ -599,7 +599,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e case (PLASTICITY_isotropic_ID) plasticityType of = phasememberAt(ipc,ip,el) instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, math_Mandel6to33(S6),instance,of) + call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dS, math_6toSym33(S6),instance,of) case default plasticityType my_Li = 0.0_pReal my_dLi_dS = 0.0_pReal @@ -718,7 +718,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip use math, only : & math_mul33x33, & math_mul3333xx33, & - math_Mandel66to3333, & + math_66toSym3333, & math_I3 use material, only: & material_phase, & @@ -751,7 +751,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip i, j ho = material_homogenizationAt(el) - C = math_Mandel66to3333(constitutive_homogenizedC(ipc,ip,el)) + C = math_66toSym3333(constitutive_homogenizedC(ipc,ip,el)) DegradationLoop: do d = 1_pInt, phase_NstiffnessDegradations(material_phase(ipc,ip,el)) degradationType: select case(phase_stiffnessDegradation(d,material_phase(ipc,ip,el))) @@ -786,8 +786,8 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac debug_levelBasic use math, only: & math_mul33x33, & - math_Mandel6to33, & - math_Mandel33to6, & + math_6toSym33, & + math_sym33to6, & math_mul33x33 use mesh, only: & mesh_NcpElems, & @@ -862,7 +862,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(S6)) + Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_6toSym33(S6)) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -892,7 +892,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac call plastic_disloucla_dotState (Mp,temperature(ho)%p(tme),instance,of) case (PLASTICITY_NONLOCAL_ID) plasticityType - call plastic_nonlocal_dotState (math_Mandel33to6(Mp),FeArray,FpArray,temperature(ho)%p(tme), & + call plastic_nonlocal_dotState (math_sym33to6(Mp),FeArray,FpArray,temperature(ho)%p(tme), & subdt,subfracArray,ip,el) end select plasticityType @@ -1001,7 +1001,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) use prec, only: & pReal use math, only: & - math_Mandel6to33, & + math_6toSym33, & math_mul33x33 use mesh, only: & mesh_NcpElems, & @@ -1076,7 +1076,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) constitutive_postResults = 0.0_pReal - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(S6)) + Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_6toSym33(S6)) ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) From 8c18b294201b405de83a0955e9ff9525b6567516 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 11:37:50 +0100 Subject: [PATCH 280/372] mutual unification --- src/plastic_disloUCLA.f90 | 29 ++---- src/plastic_dislotwin.f90 | 185 ++++++++++++++++++-------------------- 2 files changed, 95 insertions(+), 119 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index e386a9808..eea064158 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -73,7 +73,7 @@ module plastic_disloUCLA integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID !< ID of each post result output logical :: & - dipoleformation + dipoleFormation !< flag indicating consideration of dipole formation end type !< container type for internal constitutive parameters type, private :: tDisloUCLAState @@ -127,7 +127,6 @@ subroutine plastic_disloUCLA_init() debug_constitutive,& debug_levelBasic use math, only: & - math_mul3x3, & math_expand use IO, only: & IO_error, & @@ -148,8 +147,6 @@ subroutine plastic_disloUCLA_init() implicit none integer(pInt) :: & - index_myFamily, index_otherFamily, & - f,j,k,o, & Ninstance, & p, i, & NipcMyPhase, & @@ -222,9 +219,13 @@ subroutine plastic_disloUCLA_init() prm%nonSchmid_pos = prm%Schmid prm%nonSchmid_neg = prm%Schmid endif + prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & config%getString('lattice_structure')) + prm%forestProjectionEdge = lattice_forestProjection(prm%Nslip,config%getString('lattice_structure'),& + config%getFloat('c/a',defaultVal=0.0_pReal)) + prm%rho0 = config%getFloats('rhoedge0', requiredSize=size(prm%Nslip)) prm%rhoDip0 = config%getFloats('rhoedgedip0', requiredSize=size(prm%Nslip)) prm%v0 = config%getFloats('v0', requiredSize=size(prm%Nslip)) @@ -334,24 +335,6 @@ subroutine plastic_disloUCLA_init() prm%totalNslip,0_pInt,0_pInt) plasticState(p)%sizePostResults = sum(plastic_disloUCLA_sizePostResult(:,phase_plasticityInstance(p))) - allocate(prm%forestProjectionEdge(prm%totalNslip,prm%totalNslip),source = 0.0_pReal) - - i = 0_pInt - mySlipFamilies: do f = 1_pInt,size(prm%Nslip,1) - index_myFamily = sum(prm%Nslip(1:f-1_pInt)) - - slipSystemsLoop: do j = 1_pInt,prm%Nslip(f) - i = i + 1_pInt - do o = 1_pInt, size(prm%Nslip,1) - index_otherFamily = sum(prm%Nslip(1:o-1_pInt)) - do k = 1_pInt,prm%Nslip(o) ! loop over (active) systems in other family (slip) - prm%forestProjectionEdge(index_myFamily+j,index_otherFamily+k) = & - abs(math_mul3x3(lattice_sn(:,sum(lattice_NslipSystem(1:f-1,p))+j,p), & - lattice_st(:,sum(lattice_NslipSystem(1:o-1,p))+k,p))) - enddo; enddo - enddo slipSystemsLoop - enddo mySlipFamilies - !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState startIndex = 1_pInt @@ -372,7 +355,7 @@ subroutine plastic_disloUCLA_init() endIndex = endIndex + prm%totalNslip stt%accshear=>plasticState(p)%state(startIndex:endIndex,:) dot%accshear=>plasticState(p)%dotState(startIndex:endIndex,:) - plasticState(p)%aTolState(startIndex:endIndex) = 1e6_pReal !ToDo: better make optional parameter + plasticState(p)%aTolState(startIndex:endIndex) = 1.0e6_pReal !ToDo: better make optional parameter ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 29679233d..8637ed1cb 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -11,19 +11,19 @@ module plastic_dislotwin use prec, only: & pReal, & pInt - + implicit none private integer(pInt), dimension(:,:), allocatable, target, public :: & - plastic_dislotwin_sizePostResult !< size of each post result output + plastic_dislotwin_sizePostResult !< size of each post result output character(len=64), dimension(:,:), allocatable, target, public :: & - plastic_dislotwin_output !< name of each post result output - - real(pReal), parameter, private :: & - kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin + plastic_dislotwin_output !< name of each post result output - enum, bind(c) - enumerator :: & + real(pReal), parameter, private :: & + kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin + + enum, bind(c) + enumerator :: & undefined_ID, & edge_density_ID, & dipole_density_ID, & @@ -45,7 +45,7 @@ module plastic_dislotwin stress_trans_fraction_ID, & strain_trans_fraction_ID end enum - + type, private :: tParameters real(pReal) :: & mu, & @@ -99,12 +99,12 @@ module plastic_dislotwin shear_twin, & !< characteristic shear for twins B !< drag coefficient real(pReal), dimension(:,:), allocatable :: & - interaction_SlipSlip, & !< coefficients for slip-slip interaction for each interaction type - interaction_SlipTwin, & !< coefficients for slip-twin interaction for each interaction type - interaction_TwinSlip, & !< coefficients for twin-slip interaction for each interaction type - interaction_TwinTwin, & !< coefficients for twin-twin interaction for each interaction type - interaction_SlipTrans, & !< coefficients for slip-trans interaction for each interaction type - interaction_TransTrans !< coefficients for trans-trans interaction for each interaction type + interaction_SlipSlip, & !< + interaction_SlipTwin, & !< + interaction_TwinSlip, & !< + interaction_TwinTwin, & !< + interaction_SlipTrans, & !< + interaction_TransTrans !< integer(pInt), dimension(:,:), allocatable :: & fcc_twinNucleationSlipPair ! ToDo: Better name? Is also use for trans real(pReal), dimension(:,:), allocatable :: & @@ -116,27 +116,21 @@ module plastic_dislotwin Schmid_twin, & C66_twin, & C66_trans - logical :: & - dipoleFormation !< flag indicating consideration of dipole formation - - integer(kind(undefined_ID)), dimension(:), allocatable :: & - outputID !< ID of each post result output - - logical :: & - fccTwinTransNucleation !< twinning and transformation models are for fcc integer(pInt) :: & - totalNslip, & !< number of active slip systems for each family and instance - totalNtwin, & !< number of active twin systems for each family and instance - totalNtrans !< number of active transformation systems for each family and instance + totalNslip, & !< total number of active slip system + totalNtwin, & !< total number of active twin system + totalNtrans !< total number of active transformation system integer(pInt), dimension(:), allocatable :: & - Nslip, & !< number of active slip systems for each family and instance - Ntwin, & !< number of active twin systems for each family and instance - Ntrans !< number of active transformation systems for each family and instance - end type - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - + Nslip, & !< number of active slip systems for each family + Ntwin, & !< number of active twin systems for each family + Ntrans !< number of active transformation systems for each family + integer(kind(undefined_ID)), dimension(:), allocatable :: & + outputID !< ID of each post result output + logical :: & + fccTwinTransNucleation, & !< twinning and transformation models are for fcc + dipoleFormation !< flag indicating consideration of dipole formation + end type !< container type for internal constitutive parameters + type, private :: tDislotwinState real(pReal), pointer, dimension(:,:) :: & rhoEdge, & @@ -150,7 +144,7 @@ module plastic_dislotwin end type tDislotwinState type, private :: tDislotwinMicrostructure - real(pReal), allocatable, dimension(:,:) :: & + real(pReal), allocatable, dimension(:,:) :: & invLambdaSlip, & invLambdaSlipTwin, & invLambdaTwin, & @@ -168,11 +162,13 @@ module plastic_dislotwin tau_r_trans !< stress to bring partial close together for each trans system and instance end type tDislotwinMicrostructure +!-------------------------------------------------------------------------------------------------- +! containers for parameters and state + type(tParameters), allocatable, dimension(:), private :: param type(tDislotwinState), allocatable, dimension(:), private :: & - state, & - dotState - type(tDislotwinMicrostructure), allocatable, dimension(:), private :: & - microstructure + dotState, & + state + type(tDislotwinMicrostructure), allocatable, dimension(:), private :: microstructure public :: & plastic_dislotwin_init, & @@ -181,6 +177,10 @@ module plastic_dislotwin plastic_dislotwin_LpAndItsTangent, & plastic_dislotwin_dotState, & plastic_dislotwin_postResults + private :: & + kinetics_slip, & + kinetics_twin, & + kinetics_trans contains @@ -205,9 +205,6 @@ subroutine plastic_dislotwin_init debug_constitutive,& debug_levelBasic use math, only: & - math_rotate_forward3333, & - math_Mandel3333to66, & - math_mul3x3, & math_expand,& PI use IO, only: & @@ -229,25 +226,25 @@ subroutine plastic_dislotwin_init use lattice implicit none - integer(pInt) :: Ninstance,& - i,p, & - offset_slip, & - startIndex, endIndex, outputSize - integer(pInt) :: sizeState, sizeDotState - integer(pInt) :: NipcMyPhase - + integer(pInt) :: & + Ninstance, & + p, i, & + NipcMyPhase, outputSize, & + sizeState, sizeDotState, & + startIndex, endIndex + integer(pInt), dimension(1,200), parameter :: lattice_ntranssystem = 12 ! HACK!! integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer(kind(undefined_ID)) :: & - outputID !< ID of each post result output + outputID character(len=pStringLen) :: & extmsg = '' character(len=65536), dimension(:), allocatable :: & - outputs + outputs write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_DISLOTWIN_label//' init -+>>>' write(6,'(/,a)') ' A. Ma and F. Roters, Acta Materialia, 52(12):3603–3612, 2004' @@ -258,10 +255,9 @@ subroutine plastic_dislotwin_init write(6,'(a,/)') ' https://doi.org/10.1016/j.actamat.2016.07.032' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - + Ninstance = int(count(phase_plasticity == PLASTICITY_DISLOTWIN_ID),pInt) - if (Ninstance == 0_pInt) return - + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance @@ -275,7 +271,7 @@ subroutine plastic_dislotwin_init allocate(dotState(Ninstance)) allocate(microstructure(Ninstance)) - do p = 1_pInt, size(phase_plasticityInstance) + do p = 1_pInt, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_DISLOTWIN_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -291,24 +287,22 @@ subroutine plastic_dislotwin_init !-------------------------------------------------------------------------------------------------- ! slip related parameters - prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) slipActive: if (prm%totalNslip > 0_pInt) then + prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,config%getString('lattice_structure'),& + config%getFloat('c/a',defaultVal=0.0_pReal)) + prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & + config%getFloats('interaction_slipslip'), & + config%getString('lattice_structure')) + prm%forestProjection = lattice_forestProjection (prm%Nslip,config%getString('lattice_structure'),& + config%getFloat('c/a',defaultVal=0.0_pReal)) prm%fccTwinTransNucleation = merge(.true., .false., lattice_structure(p) == LATTICE_FCC_ID) & .and. (prm%Nslip(1) == 12_pInt) if(prm%fccTwinTransNucleation) & prm%fcc_twinNucleationSlipPair = lattice_fcc_twinNucleationSlipPair - prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,config%getString('lattice_structure'),& - config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%forestProjection = lattice_forestProjection (prm%Nslip,config%getString('lattice_structure'),& - config%getFloat('c/a',defaultVal=0.0_pReal)) - - prm%interaction_SlipSlip = lattice_interaction_SlipSlip(prm%Nslip, & - config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure')) - prm%rho0 = config%getFloats('rhoedge0', requiredSize=size(prm%Nslip)) !ToDo: rename to rho_0 prm%rhoDip0 = config%getFloats('rhoedgedip0',requiredSize=size(prm%Nslip)) !ToDo: rename to rho_dip_0 prm%v0 = config%getFloats('v0', requiredSize=size(prm%Nslip)) @@ -595,75 +589,72 @@ subroutine plastic_dislotwin_init plastic_dislotwin_sizePostResult(i,phase_plasticityInstance(p)) = outputSize prm%outputID = [prm%outputID, outputID] endif + enddo - !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase=count(material_phase==p) - sizeDotState = int(size(['rho ','rhoDip ','accshearslip']),pInt) * prm%totalNslip & - + int(size(['twinFraction','accsheartwin']),pInt) * prm%totalNtwin & - + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans - sizeState = sizeDotState + NipcMyPhase = count(material_phase == p) + sizeDotState = int(size(['rho ','rhoDip ','accshearslip']),pInt) * prm%totalNslip & + + int(size(['twinFraction','accsheartwin']),pInt) * prm%totalNtwin & + + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans + sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & prm%totalNslip,prm%totalNtwin,prm%totalNtrans) plasticState(p)%sizePostResults = sum(plastic_dislotwin_sizePostResult(:,phase_plasticityInstance(p))) - ! ToDo: do later on - offset_slip = 2_pInt*plasticState(p)%nslip - plasticState(p)%slipRate => & - plasticState(p)%dotState(offset_slip+1:offset_slip+plasticState(p)%nslip,1:NipcMyPhase) - plasticState(p)%accumulatedSlip => & - plasticState(p)%state (offset_slip+1:offset_slip+plasticState(p)%nslip,1:NipcMyPhase) - - startIndex=1_pInt - endIndex=prm%totalNslip +!-------------------------------------------------------------------------------------------------- +! locally defined state aliases and initialization of state0 and aTolState + startIndex = 1_pInt + endIndex = prm%totalNslip stt%rhoEdge=>plasticState(p)%state(startIndex:endIndex,:) stt%rhoEdge= spread(prm%rho0,2,NipcMyPhase) dot%rhoEdge=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolRho - startIndex=endIndex+1 - endIndex=endIndex+prm%totalNslip + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip stt%rhoEdgeDip=>plasticState(p)%state(startIndex:endIndex,:) stt%rhoEdgeDip= spread(prm%rhoDip0,2,NipcMyPhase) dot%rhoEdgeDip=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolRho - - startIndex=endIndex+1 - endIndex=endIndex+prm%totalNslip + + startIndex = endIndex + 1_pInt + endIndex = endIndex + prm%totalNslip stt%accshear_slip=>plasticState(p)%state(startIndex:endIndex,:) dot%accshear_slip=>plasticState(p)%dotState(startIndex:endIndex,:) - plasticState(p)%aTolState(startIndex:endIndex) = 1.0e6_pReal + plasticState(p)%aTolState(startIndex:endIndex) = 1.0e6_pReal !ToDo: better make optional parameter + ! global alias + plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) + plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) - startIndex=endIndex+1 + startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtwin stt%twinFraction=>plasticState(p)%state(startIndex:endIndex,:) dot%twinFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTwinFrac - startIndex=endIndex+1 + startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtwin stt%accshear_twin=>plasticState(p)%state(startIndex:endIndex,:) dot%accshear_twin=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = 1.0e6_pReal - startIndex=endIndex+1 + startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtrans stt%stressTransFraction=>plasticState(p)%state(startIndex:endIndex,:) dot%stressTransFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTransFrac - startIndex=endIndex+1 + startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtrans stt%strainTransFraction=>plasticState(p)%state(startIndex:endIndex,:) dot%strainTransFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTransFrac - plasticState(p)%state0 = plasticState(p)%state - dot%whole => plasticState(p)%dotState + dot%whole => plasticState(p)%dotState !ToDo: needed? allocate(mse%invLambdaSlip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) allocate(mse%invLambdaSlipTwin (prm%totalNslip, NipcMyPhase),source=0.0_pReal) @@ -683,11 +674,15 @@ subroutine plastic_dislotwin_init allocate(mse%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(mse%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + end associate + enddo - + end subroutine plastic_dislotwin_init + !-------------------------------------------------------------------------------------------------- !> @brief returns the homogenized elasticity matrix !-------------------------------------------------------------------------------------------------- @@ -894,7 +889,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) dEq0 use math, only: & math_mul33xx33, & - math_Mandel6to33, & pi use material, only: & plasticState @@ -1164,8 +1158,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe dEq0 use math, only: & PI, & - math_mul33xx33, & - math_Mandel6to33 + math_mul33xx33 implicit none real(pReal), dimension(3,3),intent(in) :: & From aecb5f20bf9ef6450b0a8013e882007222e8b985 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 12:15:11 +0100 Subject: [PATCH 281/372] shortened --- src/plastic_dislotwin.f90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 8637ed1cb..aa3d2a1fa 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -686,7 +686,7 @@ end subroutine plastic_dislotwin_init !-------------------------------------------------------------------------------------------------- !> @brief returns the homogenized elasticity matrix !-------------------------------------------------------------------------------------------------- -function plastic_dislotwin_homogenizedC(ipc,ip,el) +function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC) use material, only: & material_phase, & phase_plasticityInstance, & @@ -694,7 +694,7 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) implicit none real(pReal), dimension(6,6) :: & - plastic_dislotwin_homogenizedC + homogenizedC integer(pInt), intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point @@ -713,18 +713,19 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) - sum(stt%stressTransFraction(1_pInt:prm%totalNtrans,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) - plastic_dislotwin_homogenizedC = f_unrotated * prm%C66 + homogenizedC = f_unrotated * prm%C66 do i=1_pInt,prm%totalNtwin - plastic_dislotwin_homogenizedC = plastic_dislotwin_homogenizedC & - + stt%twinFraction(i,of)*prm%C66_twin(1:6,1:6,i) + homogenizedC = homogenizedC & + + stt%twinFraction(i,of)*prm%C66_twin(1:6,1:6,i) enddo do i=1_pInt,prm%totalNtrans - plastic_dislotwin_homogenizedC = plastic_dislotwin_homogenizedC & - +(stt%stressTransFraction(i,of)+stt%strainTransFraction(i,of))*& - prm%C66_trans(1:6,1:6,i) + homogenizedC = homogenizedC & + +(stt%stressTransFraction(i,of)+stt%strainTransFraction(i,of))*prm%C66_trans(1:6,1:6,i) enddo + end associate - end function plastic_dislotwin_homogenizedC + +end function plastic_dislotwin_homogenizedC !-------------------------------------------------------------------------------------------------- From 85c5c4ba12b2d54618d731e97896131cfb750e50 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 14:19:18 +0100 Subject: [PATCH 282/372] includes references to DAMASK paper --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 683bf0074..2d7a5067f 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 683bf0074f3fa079989b51f5a67aa593b7577f0b +Subproject commit 2d7a5067f49dea6fac4ecc83f8b784fcfb380aca From 3843bf599cb18d879a4e48ee8cad0a56bb508595 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 15:14:50 +0100 Subject: [PATCH 283/372] removed - accumulatedshear_twin: linearly depends on twin volume fraction - output of further derived quantities --- src/plastic_dislotwin.f90 | 103 +------------------------------------- 1 file changed, 2 insertions(+), 101 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index aa3d2a1fa..7b3f3fa31 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -33,10 +33,7 @@ module plastic_dislotwin resolved_stress_slip_ID, & threshold_stress_slip_ID, & edge_dipole_distance_ID, & - stress_exponent_ID, & twin_fraction_ID, & - shear_rate_twin_ID, & - accumulated_shear_twin_ID, & mfp_twin_ID, & resolved_stress_twin_ID, & threshold_stress_twin_ID, & @@ -137,7 +134,6 @@ module plastic_dislotwin rhoEdgeDip, & accshear_slip, & twinFraction, & - accshear_twin, & stressTransFraction, & strainTransFraction, & whole @@ -545,19 +541,10 @@ subroutine plastic_dislotwin_init case ('edge_dipole_distance') outputID = merge(edge_dipole_distance_ID,undefined_ID,prm%totalNslip > 0_pInt) outputSize = prm%totalNslip - case ('stress_exponent') - outputID = merge(stress_exponent_ID,undefined_ID,prm%totalNslip > 0_pInt) - outputSize = prm%totalNslip case ('twin_fraction') outputID = merge(twin_fraction_ID,undefined_ID,prm%totalNtwin >0_pInt) outputSize = prm%totalNtwin - case ('shear_rate_twin','shearrate_twin') - outputID = merge(shear_rate_twin_ID,undefined_ID,prm%totalNtwin >0_pInt) - outputSize = prm%totalNtwin - case ('accumulated_shear_twin') - outputID = merge(accumulated_shear_twin_ID,undefined_ID,prm%totalNtwin >0_pInt) - outputSize = prm%totalNtwin case ('mfp_twin') outputID = merge(mfp_twin_ID,undefined_ID,prm%totalNtwin >0_pInt) outputSize = prm%totalNtwin @@ -596,7 +583,7 @@ subroutine plastic_dislotwin_init ! allocate state arrays NipcMyPhase = count(material_phase == p) sizeDotState = int(size(['rho ','rhoDip ','accshearslip']),pInt) * prm%totalNslip & - + int(size(['twinFraction','accsheartwin']),pInt) * prm%totalNtwin & + + int(size(['twinFraction']),pInt) * prm%totalNtwin & + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans sizeState = sizeDotState @@ -636,12 +623,6 @@ subroutine plastic_dislotwin_init dot%twinFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTwinFrac - startIndex = endIndex + 1_pInt - endIndex=endIndex+prm%totalNtwin - stt%accshear_twin=>plasticState(p)%state(startIndex:endIndex,:) - dot%accshear_twin=>plasticState(p)%dotState(startIndex:endIndex,:) - plasticState(p)%aTolState(startIndex:endIndex) = 1.0e6_pReal - startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtrans stt%stressTransFraction=>plasticState(p)%state(startIndex:endIndex,:) @@ -992,7 +973,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) Ndot0_twin=prm%Ndot0_twin(i) endif isFCCtwin dot%twinFraction(i,of) = f_unrotated * mse%twinVolume(i,of)*Ndot0_twin*exp(-StressRatio_r) - dot%accshear_twin(i,of) = dot%twinFraction(i,of) * prm%shear_twin(i) endif significantTwinStress enddo twinState @@ -1019,9 +999,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) endif isFCCtrans dot%strainTransFraction(i,of) = f_unrotated * & mse%martensiteVolume(i,of)*Ndot0_trans*exp(-StressRatio_s) - !* Dotstate for accumulated shear due to transformation - !dot%accshear_trans(i,of) = dot%strainTransFraction(i,of) * & - ! lattice_sheartrans(index_myfamily+i,ph) endif significantTransStress enddo transState @@ -1246,56 +1223,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe ! c = c + 6_pInt case (twin_fraction_ID) postResults(c+1_pInt:c+prm%totalNtwin) = stt%twinFraction(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin - case (shear_rate_twin_ID) - do j = 1_pInt, prm%totalNslip - tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) - if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then - StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **prm%p(j) - StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **(prm%p(j)-1.0_pReal) - BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) - DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) - - gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& - prm%q(j))*sign(1.0_pReal,tau) - else - gdot_slip(j) = 0.0_pReal - endif - enddo - - do j = 1_pInt, prm%totalNtwin - tau = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,j)) - - if ( tau > 0.0_pReal ) then - isFCCtwin: if (prm%fccTwinTransNucleation) then - s1=prm%fcc_twinNucleationSlipPair(1,j) - s2=prm%fcc_twinNucleationSlipPair(2,j) - if (tau < mse%tau_r_twin(j,of)) then - Ndot0_twin=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_twin* prm%burgers_slip(j))*& - (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)* (mse%tau_r_twin(j,of)-tau))) - else - Ndot0_twin=0.0_pReal - end if - else isFCCtwin - Ndot0_twin=prm%Ndot0_twin(j) - endif isFCCtwin - StressRatio_r = (mse%threshold_stress_twin(j,of)/tau) **prm%r(j) - postResults(c+j) = (prm%MaxTwinFraction-sumf_twin)*prm%shear_twin(j) & - * mse%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) - endif - enddo - c = c + prm%totalNtwin - case (accumulated_shear_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%accshear_twin(1_pInt:prm%totalNtwin,of) - c = c + prm%totalNtwin + c = c + prm%totalNtwin case (mfp_twin_ID) postResults(c+1_pInt:c+prm%totalNtwin) = mse%mfp_twin(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin @@ -1307,34 +1235,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe case (threshold_stress_twin_ID) postResults(c+1_pInt:c+prm%totalNtwin) = mse%threshold_stress_twin(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin - case (stress_exponent_ID) - do j = 1_pInt, prm%totalNslip - tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)) - if((abs(tau)-mse%threshold_stress_slip(j,of)) > tol_math_check) then - StressRatio_p = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **prm%p(j) - StressRatio_pminus1 = ((abs(tau)-mse%threshold_stress_slip(j,of))/& - (prm%SolidSolutionStrength+& - prm%tau_peierls(j)))& - **(prm%p(j)-1.0_pReal) - BoltzmannRatio = prm%Qedge(j)/(kB*Temperature) - DotGamma0 = stt%rhoEdge(j,of)*prm%burgers_slip(j)* prm%v0(j) - gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& - prm%q(j))*sign(1.0_pReal,tau) - - dgdot_dtauslip = abs(gdot_slip(j))*BoltzmannRatio*prm%p(j) *prm%q(j)/& - (prm%SolidSolutionStrength+ prm%tau_peierls(j))*& - StressRatio_pminus1*(1-StressRatio_p)**(prm%q(j)-1.0_pReal) - else - gdot_slip(j) = 0.0_pReal - dgdot_dtauslip = 0.0_pReal - endif - postResults(c+j) = merge(0.0_pReal,(tau/gdot_slip(j))*dgdot_dtauslip,dEq0(gdot_slip(j))) - enddo - c = c + prm%totalNslip case (stress_trans_fraction_ID) postResults(c+1_pInt:c+prm%totalNtrans) = stt%stressTransFraction(1_pInt:prm%totalNtrans,of) c = c + prm%totalNtrans From 453323d18a5cc5f2b0da578638ede3660f256021 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 15:17:26 +0100 Subject: [PATCH 284/372] use dislotwin test with sensible output --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 2d7a5067f..e03ef29af 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 2d7a5067f49dea6fac4ecc83f8b784fcfb380aca +Subproject commit e03ef29af51bf5b666a0765a137f773ca8af493d From 3fcb7d72c84bfbe98c6b2c4079907773f6c14b7f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 16:39:36 +0100 Subject: [PATCH 285/372] shortened --- src/plastic_dislotwin.f90 | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 7b3f3fa31..6ad0b73d9 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -53,7 +53,6 @@ module plastic_dislotwin GrainSize, & ! tol_math_check) then StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand gdot_sb = sign(prm%sbVelocity*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**prm%qShearBand), tau) - dgdot_dtau = ((abs(gdot_sb)*BoltzmannRatio* prm%pShearBand*prm%qShearBand)/ prm%sbResistance) & + dgdot_dtau = (abs(gdot_sb)*BoltzmannRatio* prm%pShearBand*prm%qShearBand)/ prm%sbResistance & * (abs(tau)/prm%sbResistance)**(prm%pShearBand-1.0_pReal) & * (1.0_pReal-StressRatio_p)**(prm%qShearBand-1.0_pReal) @@ -814,13 +813,11 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, endif shearBandingContribution call kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin,dgdot_dtau_twin) - gdot_twin = f_unrotated * gdot_twin - dgdot_dtau_twin = f_unrotated * dgdot_dtau_twin twinContibution: do i = 1_pInt, prm%totalNtwin - Lp = Lp + gdot_twin(i)*prm%Schmid_twin(1:3,1:3,i) + Lp = Lp + gdot_twin(i)*prm%Schmid_twin(1:3,1:3,i) * f_unrotated forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & - + dgdot_dtau_twin(i)* prm%Schmid_twin(k,l,i)*prm%Schmid_twin(m,n,i) + + dgdot_dtau_twin(i)* prm%Schmid_twin(k,l,i)*prm%Schmid_twin(m,n,i) * f_unrotated enddo twinContibution transConstribution: do i = 1_pInt, prm%totalNtrans From 5903e19e18a620205bbe8eaacdc7bbc3e5bc6bef Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 16:59:44 +0100 Subject: [PATCH 286/372] signature as in disloUCLA --- src/plastic_dislotwin.f90 | 59 ++++++++++++++++++++++----------------- 1 file changed, 33 insertions(+), 26 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 6ad0b73d9..111930cab 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -772,7 +772,7 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, Lp = 0.0_pReal dLp_dMp = 0.0_pReal - call kinetics_slip(prm,stt,mse,of,Mp,temperature,gdot_slip,dgdot_dtau_slip) + call kinetics_slip(Mp,temperature,instance,of,gdot_slip,dgdot_dtau_slip) slipContribution: do i = 1_pInt, prm%totalNslip Lp = Lp + gdot_slip(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) & @@ -900,7 +900,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) - sum(stt%stressTransFraction(1_pInt:prm%totalNtrans,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) - call kinetics_slip(prm,stt,mse,of,Mp,temperature,gdot_slip) + call kinetics_slip(Mp,temperature,instance,of,gdot_slip) slipState: do i = 1_pInt, prm%totalNslip tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) @@ -1172,7 +1172,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNslip) = stt%rhoEdgeDip(1_pInt:prm%totalNslip,of) c = c + prm%totalNslip case (shear_rate_slip_ID) - call kinetics_slip(prm,stt,mse,of,Mp,temperature,postResults(c+1:c+prm%totalNslip)) + call kinetics_slip(Mp,temperature,instance,of,postResults(c+1:c+prm%totalNslip)) c = c + prm%totalNslip case (accumulated_shear_slip_ID) postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip,of) @@ -1246,9 +1246,14 @@ end function plastic_dislotwin_postResults !-------------------------------------------------------------------------------------------------- -!> @brief calculates shear rates on slip systems +!> @brief Shear rates on slip systems, their derivatives with respect to resolved stress and the +! resolved stresss +!> @details Derivatives and resolved stress are calculated only optionally. +! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to +! have the optional arguments at the end !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics_slip(prm,stt,mse,of,Mp,temperature,gdot_slip,dgdot_dtau_slip) +pure subroutine kinetics_slip(Mp,Temperature,instance,of, & + gdot_slip,dgdot_dtau_slip,tau_slip) use prec, only: & tol_math_check, & dNeq0 @@ -1256,43 +1261,42 @@ pure subroutine kinetics_slip(prm,stt,mse,of,Mp,temperature,gdot_slip,dgdot_dtau math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tDislotwinState), intent(in) :: & - stt - integer(pInt), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + real(pReal), intent(in) :: & + temperature !< temperature + integer(pInt), intent(in) :: & + instance, & of - type(tDislotwinMicrostructure), intent(in) :: & - mse - real(pReal), dimension(prm%totalNslip), intent(out) :: & + + real(pReal), dimension(param(instance)%totalNslip), intent(out) :: & gdot_slip - real(pReal), dimension(prm%totalNslip), optional, intent(out) :: & - dgdot_dtau_slip - real(pReal), dimension(prm%totalNslip) :: & + real(pReal), dimension(param(instance)%totalNslip), optional, intent(out) :: & + dgdot_dtau_slip, & + tau_slip + real(pReal), dimension(param(instance)%totalNslip) :: & dgdot_dtau - real(pReal), dimension(3,3), intent(in) :: & - Mp - real(pReal), intent(in) :: & - temperature - real, dimension(prm%totalNslip) :: & + real, dimension(param(instance)%totalNslip) :: & tau, & stressRatio, & StressRatio_p, & BoltzmannRatio, & - v_wait_inverse, & !< inverse of the effective velocity of a dislocation waiting at obstacles (unsigned) - v_run_inverse, & !< inverse of the velocity of a free moving dislocation (unsigned) + v_wait_inverse, & !< inverse of the effective velocity of a dislocation waiting at obstacles (unsigned) + v_run_inverse, & !< inverse of the velocity of a free moving dislocation (unsigned) dV_wait_inverse_dTau, & dV_run_inverse_dTau, & dV_dTau, & - tau_eff !< effective resolved stress + tau_eff !< effective resolved stress integer(pInt) :: i + + associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) do i = 1_pInt, prm%totalNslip tau(i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) enddo - tau_eff = abs(tau)-mse%threshold_stress_slip(:,of) + tau_eff = abs(tau)-dst%threshold_stress_slip(:,of) significantStress: where(tau_eff > tol_math_check) stressRatio = tau_eff/(prm%SolidSolutionStrength+prm%tau_peierls) @@ -1317,6 +1321,9 @@ pure subroutine kinetics_slip(prm,stt,mse,of,Mp,temperature,gdot_slip,dgdot_dtau end where significantStress if(present(dgdot_dtau_slip)) dgdot_dtau_slip = dgdot_dtau + if(present(tau_slip)) tau_slip = tau + + end associate end subroutine kinetics_slip @@ -1340,7 +1347,7 @@ pure subroutine kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin, of type(tDislotwinMicrostructure), intent(in) :: & mse - real(pReal), dimension(prm%totalNslip), intent(out) :: & + real(pReal), dimension(prm%totalNslip), intent(in) :: & gdot_slip real(pReal), dimension(prm%totalNtwin), intent(out) :: & gdot_twin From c9e050c031ba4ee0f669e055840e2ef71b92bd7a Mon Sep 17 00:00:00 2001 From: Test User Date: Sun, 27 Jan 2019 17:50:07 +0100 Subject: [PATCH 287/372] [skip ci] updated version information after successful test of v2.0.2-1519-g453323d1 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 6dee49c94..a51af2ff4 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1516-gffd29bdc +v2.0.2-1519-g453323d1 From 4b3efac4e5a898a813ee98c0180b580c930a9d6d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 19:44:53 +0100 Subject: [PATCH 288/372] simplified --- src/plastic_dislotwin.f90 | 319 ++++++++++++++------------------------ 1 file changed, 115 insertions(+), 204 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 111930cab..d85855577 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -228,7 +228,6 @@ subroutine plastic_dislotwin_init sizeState, sizeDotState, & startIndex, endIndex - integer(pInt), dimension(1,200), parameter :: lattice_ntranssystem = 12 ! HACK!! integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] @@ -256,7 +255,6 @@ subroutine plastic_dislotwin_init if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(plastic_dislotwin_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) allocate(plastic_dislotwin_output(maxval(phase_Noutput),Ninstance)) plastic_dislotwin_output = '' @@ -728,19 +726,20 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, integer(pInt), intent(in) :: instance,of real(pReal), intent(in) :: Temperature - integer(pInt) :: i,k,l,m,n,s1,s2 + integer(pInt) :: i,k,l,m,n real(pReal) :: f_unrotated,StressRatio_p,& BoltzmannRatio, & - Ndot0_trans,StressRatio_s, & dgdot_dtau, & tau real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip,dgdot_dtau_slip real(pReal), dimension(param(instance)%totalNtwin) :: & gdot_twin,dgdot_dtau_twin - real(pReal):: gdot_sb,gdot_trans + real(pReal), dimension(param(instance)%totalNtrans) :: & + gdot_trans,dgdot_dtau_trans + real(pReal):: gdot_sb real(pReal), dimension(3,3) :: eigVectors, Schmid_shearBand - real(pReal), dimension(3) :: eigValues, sb_s, sb_m + real(pReal), dimension(3) :: eigValues logical :: error real(pReal), dimension(3,6), parameter :: & sb_sComposition = & @@ -790,16 +789,14 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, call math_eigenValuesVectorsSym(Mp,eigValues,eigVectors,error) do i = 1_pInt,6_pInt - sb_s = 0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_sComposition(1:3,i)) - sb_m = 0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_mComposition(1:3,i)) - Schmid_shearBand = math_tensorproduct33(0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_sComposition(1:3,i)),& - 0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_mComposition(1:3,i))) + Schmid_shearBand = 0.5_pReal * math_tensorproduct33(math_mul33x3(eigVectors,sb_sComposition(1:3,i)),& + math_mul33x3(eigVectors,sb_mComposition(1:3,i))) tau = math_mul33xx33(Mp,Schmid_shearBand) significantShearBandStress: if (abs(tau) > tol_math_check) then - StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand + StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand gdot_sb = sign(prm%sbVelocity*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**prm%qShearBand), tau) - dgdot_dtau = (abs(gdot_sb)*BoltzmannRatio* prm%pShearBand*prm%qShearBand)/ prm%sbResistance & + dgdot_dtau = abs(gdot_sb)*BoltzmannRatio* prm%pShearBand*prm%qShearBand/ prm%sbResistance & * (abs(tau)/prm%sbResistance)**(prm%pShearBand-1.0_pReal) & * (1.0_pReal-StressRatio_p)**(prm%qShearBand-1.0_pReal) @@ -812,47 +809,22 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, endif shearBandingContribution - call kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin,dgdot_dtau_twin) + call kinetics_twin(Mp,temperature,gdot_slip,instance,of,gdot_twin,dgdot_dtau_twin) twinContibution: do i = 1_pInt, prm%totalNtwin Lp = Lp + gdot_twin(i)*prm%Schmid_twin(1:3,1:3,i) * f_unrotated forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + dgdot_dtau_twin(i)* prm%Schmid_twin(k,l,i)*prm%Schmid_twin(m,n,i) * f_unrotated enddo twinContibution + + call kinetics_twin(Mp,temperature,gdot_slip,instance,of,gdot_trans,dgdot_dtau_trans) + transContibution: do i = 1_pInt, prm%totalNtrans + Lp = Lp + gdot_trans(i)*prm%Schmid_trans(1:3,1:3,i) * f_unrotated + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + + dgdot_dtau_trans(i)* prm%Schmid_trans(k,l,i)*prm%Schmid_trans(m,n,i) * f_unrotated + enddo transContibution - transConstribution: do i = 1_pInt, prm%totalNtrans - - tau = math_mul33xx33(Mp,prm%Schmid_trans(1:3,1:3,i)) - - significantTransStress: if (tau > tol_math_check) then - StressRatio_s = (mse%threshold_stress_trans(i,of)/tau)**prm%s(i) - - isFCCtrans: if (prm%fccTwinTransNucleation) then - s1=prm%fcc_twinNucleationSlipPair(1,i) - s2=prm%fcc_twinNucleationSlipPair(2,i) - if (tau < mse%tau_r_trans(i,of)) then - Ndot0_trans=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& !!!!! correct? - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_trans*prm%burgers_slip(i))*& - (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)*(mse%tau_r_trans(i,of)-tau))) - else - Ndot0_trans=0.0_pReal - end if - else isFCCtrans - Ndot0_trans=prm%Ndot0_trans(i) - endif isFCCtrans - - gdot_trans = mse%martensiteVolume(i,of) * Ndot0_trans*exp(-StressRatio_s) - gdot_trans = f_unrotated * gdot_trans - dgdot_dtau = ((gdot_trans*prm%s(i))/tau)*StressRatio_s - Lp = Lp + gdot_trans*prm%Schmid_trans(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) & - dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & - + dgdot_dtau * prm%Schmid_trans(k,l,i)* prm%Schmid_trans(m,n,i) - endif significantTransStress - - enddo transConstribution end associate @@ -881,14 +853,18 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) instance, & of - integer(pInt) :: i,s1,s2 + integer(pInt) :: i real(pReal) :: f_unrotated,& - EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,Ndot0_twin,& - Ndot0_trans,StressRatio_r,StressRatio_s,EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & + EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,& + EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & DotRhoDipFormation,DotRhoMultiplication,DotRhoEdgeEdgeAnnihilation, & tau real(pReal), dimension(plasticState(instance)%Nslip) :: & - gdot_slip + gdot_slip + real(pReal), dimension(plasticState(instance)%Ntwin) :: & + gdot_twin + real(pReal), dimension(plasticState(instance)%Ntrans) :: & + gdot_trans associate(prm => param(instance), stt => state(instance), & dot => dotstate(instance), mse => microstructure(instance)) @@ -901,6 +877,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) call kinetics_slip(Mp,temperature,instance,of,gdot_slip) + slipState: do i = 1_pInt, prm%totalNslip tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) @@ -922,10 +899,10 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) endif significantSlipStress2 !* Spontaneous annihilation of 2 single edge dislocations - DotRhoEdgeEdgeAnnihilation = ((2.0_pReal*EdgeDipMinDistance)/prm%burgers_slip(i))*& - stt%rhoEdge(i,of)*abs(gdot_slip(i)) + DotRhoEdgeEdgeAnnihilation = 2.0_pReal*EdgeDipMinDistance/prm%burgers_slip(i) & + * stt%rhoEdge(i,of)*abs(gdot_slip(i)) !* Spontaneous annihilation of a single edge dislocation with a dipole constituent - DotRhoEdgeDipAnnihilation = ((2.0_pReal*EdgeDipMinDistance)/prm%burgers_slip(i)) & + DotRhoEdgeDipAnnihilation = 2.0_pReal*EdgeDipMinDistance/prm%burgers_slip(i) & * stt%rhoEdgeDip(i,of)*abs(gdot_slip(i)) !* Dislocation dipole climb @@ -949,58 +926,14 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) dot%accshear_slip(i,of) = abs(gdot_slip(i)) enddo slipState - twinState: do i = 1_pInt, prm%totalNtwin - - tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) - - significantTwinStress: if (tau > tol_math_check) then - StressRatio_r = (mse%threshold_stress_twin(i,of)/tau)**prm%r(i) - isFCCtwin: if (prm%fccTwinTransNucleation) then - s1=prm%fcc_twinNucleationSlipPair(1,i) - s2=prm%fcc_twinNucleationSlipPair(2,i) - if (tau < mse%tau_r_twin(i,of)) then - Ndot0_twin=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_twin*prm%burgers_slip(i))*(1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)*& - (mse%tau_r_twin(i,of)-tau))) - else - Ndot0_twin=0.0_pReal - end if - else isFCCtwin - Ndot0_twin=prm%Ndot0_twin(i) - endif isFCCtwin - dot%twinFraction(i,of) = f_unrotated * mse%twinVolume(i,of)*Ndot0_twin*exp(-StressRatio_r) - endif significantTwinStress - - enddo twinState + call kinetics_twin(Mp,temperature,gdot_slip,instance,of,gdot_twin) + dot%twinFraction(:,of) = f_unrotated*gdot_twin/prm%shear_twin - transState: do i = 1_pInt, prm%totalNtrans - - tau = math_mul33xx33(Mp,prm%Schmid_trans(1:3,1:3,i)) - - significantTransStress: if (tau > tol_math_check) then - StressRatio_s = (mse%threshold_stress_trans(i,of)/tau)**prm%s(i) - isFCCtrans: if (prm%fccTwinTransNucleation) then - s1=prm%fcc_twinNucleationSlipPair(1,i) - s2=prm%fcc_twinNucleationSlipPair(2,i) - if (tau < mse%tau_r_trans(i,of)) then - Ndot0_trans=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_trans*prm%burgers_slip(i))*(1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)*& - (mse%tau_r_trans(i,of)-tau))) - else - Ndot0_trans=0.0_pReal - end if - else isFCCtrans - Ndot0_trans=prm%Ndot0_trans(i) - endif isFCCtrans - dot%strainTransFraction(i,of) = f_unrotated * & - mse%martensiteVolume(i,of)*Ndot0_trans*exp(-StressRatio_s) - endif significantTransStress - - enddo transState + call kinetics_trans(Mp,temperature,gdot_slip,instance,of,gdot_trans) + dot%twinFraction(:,of) = f_unrotated*gdot_trans end associate + end subroutine plastic_dislotwin_dotState @@ -1051,7 +984,6 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) prm%forestProjection(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation - !$OMP CRITICAL (evilmatmul) if (prm%totalNtwin > 0_pInt .and. prm%totalNslip > 0_pInt) & mse%invLambdaSlipTwin(1_pInt:prm%totalNslip,of) = & matmul(prm%interaction_SlipTwin,fOverStacksize)/(1.0_pReal-sumf_twin) @@ -1059,8 +991,7 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin !ToDo: needed? if (prm%totalNtwin > 0_pInt) & - mse%invLambdaTwin(1_pInt:prm%totalNtwin,of) = & - matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) + mse%invLambdaTwin(1_pInt:prm%totalNtwin,of) = matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation @@ -1070,10 +1001,7 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) !ToDo: needed? if (prm%totalNtrans > 0_pInt) & - - mse%invLambdaTrans(1_pInt:prm%totalNtrans,of) = & - matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) - !$OMP END CRITICAL (evilmatmul) + mse%invLambdaTrans(1_pInt:prm%totalNtrans,of) = matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) !* mean free path between 2 obstacles seen by a moving dislocation do i = 1_pInt,prm%totalNslip @@ -1082,9 +1010,8 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) prm%GrainSize/(1.0_pReal+prm%GrainSize*& (mse%invLambdaSlip(i,of) + mse%invLambdaSlipTwin(i,of) + mse%invLambdaSlipTrans(i,of))) else - mse%mfp_slip(i,of) = & - prm%GrainSize/& - (1.0_pReal+prm%GrainSize*(mse%invLambdaSlip(i,of))) !!!!!! correct? + mse%mfp_slip(i,of) = prm%GrainSize & + / (1.0_pReal+prm%GrainSize*mse%invLambdaSlip(i,of)) !!!!!! correct? endif enddo @@ -1120,7 +1047,8 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) x0 = prm%mu*prm%burgers_trans**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) mse%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) -end associate + end associate + end subroutine plastic_dislotwin_dependentState @@ -1148,20 +1076,12 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe postResults integer(pInt) :: & - o,c,j,& - s1,s2 - real(pReal) :: sumf_twin,tau,StressRatio_p,StressRatio_pminus1,BoltzmannRatio,DotGamma0,StressRatio_r,Ndot0_twin,dgdot_dtauslip, & - stressRatio - real(pReal), dimension(param(instance)%totalNslip) :: & - gdot_slip - + o,c,j associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) - - sumf_twin = sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) c = 0_pInt - postResults = 0.0_pReal + do o = 1_pInt,size(prm%outputID) select case(prm%outputID(o)) @@ -1234,14 +1154,16 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe c = c + prm%totalNtwin case (stress_trans_fraction_ID) - postResults(c+1_pInt:c+prm%totalNtrans) = stt%stressTransFraction(1_pInt:prm%totalNtrans,of) + postResults(c+1_pInt:c+prm%totalNtrans) = 0.0_pReal c = c + prm%totalNtrans case (strain_trans_fraction_ID) postResults(c+1_pInt:c+prm%totalNtrans) = stt%strainTransFraction(1_pInt:prm%totalNtrans,of) c = c + prm%totalNtrans end select enddo + end associate + end function plastic_dislotwin_postResults @@ -1320,18 +1242,19 @@ pure subroutine kinetics_slip(Mp,Temperature,instance,of, & dgdot_dtau = 0.0_pReal end where significantStress + end associate + if(present(dgdot_dtau_slip)) dgdot_dtau_slip = dgdot_dtau if(present(tau_slip)) tau_slip = tau - end associate - end subroutine kinetics_slip !-------------------------------------------------------------------------------------------------- !> @brief calculates shear rates on twin systems !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin,dgdot_dtau_twin) +pure subroutine kinetics_twin(Mp,temperature,gdot_slip,instance,of,& + gdot_twin,dgdot_dtau_twin) use prec, only: & tol_math_check, & dNeq0 @@ -1339,71 +1262,71 @@ pure subroutine kinetics_twin(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_twin, math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tDislotwinState), intent(in) :: & - stt - integer(pInt), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + real(pReal), intent(in) :: & + temperature !< temperature + integer(pInt), intent(in) :: & + instance, & of - type(tDislotwinMicrostructure), intent(in) :: & - mse - real(pReal), dimension(prm%totalNslip), intent(in) :: & + real(pReal), dimension(param(instance)%totalNslip), intent(in) :: & gdot_slip - real(pReal), dimension(prm%totalNtwin), intent(out) :: & + + real(pReal), dimension(param(instance)%totalNtwin), intent(out) :: & gdot_twin - real(pReal), dimension(prm%totalNtwin), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNtwin), optional, intent(out) :: & dgdot_dtau_twin - real(pReal), dimension(3,3), intent(in) :: & - Mp - real(pReal), intent(in) :: & - temperature - real, dimension(prm%totalNtwin) :: & + real, dimension(param(instance)%totalNtwin) :: & tau, & - Ndot0_twin, & + Ndot0, & stressRatio_r, & dgdot_dtau integer(pInt) :: i,s1,s2 + + associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) do i = 1_pInt, prm%totalNtwin tau(i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) isFCC: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) - if (tau(i) < mse%tau_r_twin(i,of)) then - Ndot0_twin=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& + if (tau(i) < dst%tau_r_twin(i,of)) then + Ndot0=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& ! ToDo: MD: it would be more consistent to use shearrates from state (prm%L0_twin*prm%burgers_slip(i))*& (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)*& - (mse%tau_r_twin(i,of)-tau))) + (dst%tau_r_twin(i,of)-tau))) else - Ndot0_twin=0.0_pReal + Ndot0=0.0_pReal end if else isFCC - Ndot0_twin=prm%Ndot0_twin(i) + Ndot0=prm%Ndot0_twin(i) endif isFCC enddo - significantStress: where(tau > tol_math_check) - StressRatio_r = (mse%threshold_stress_twin(:,of)/tau)**prm%r - gdot_twin = prm%shear_twin * mse%twinVolume(:,of) * Ndot0_twin*exp(-StressRatio_r) - dgdot_dtau = ((gdot_twin*prm%r)/tau)*StressRatio_r + StressRatio_r = (dst%threshold_stress_twin(:,of)/tau)**prm%r + gdot_twin = prm%shear_twin * dst%twinVolume(:,of) * Ndot0*exp(-StressRatio_r) + dgdot_dtau = (gdot_twin*prm%r/tau)*StressRatio_r else where significantStress gdot_twin = 0.0_pReal dgdot_dtau = 0.0_pReal end where significantStress + + end associate if(present(dgdot_dtau_twin)) dgdot_dtau_twin = dgdot_dtau end subroutine kinetics_twin - + !-------------------------------------------------------------------------------------------------- -!> @brief calculates shear rates on transformation systems +!> @brief calculates shear rates on twin systems !-------------------------------------------------------------------------------------------------- -pure subroutine kinetics_trans(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_trans,dgdot_dtau_trans) +pure subroutine kinetics_trans(Mp,temperature,gdot_slip,instance,of,& + gdot_trans,dgdot_dtau_trans) use prec, only: & tol_math_check, & dNeq0 @@ -1411,75 +1334,63 @@ pure subroutine kinetics_trans(prm,stt,mse,of,Mp,temperature,gdot_slip,gdot_tran math_mul33xx33 implicit none - type(tParameters), intent(in) :: & - prm - type(tDislotwinState), intent(in) :: & - stt - integer(pInt), intent(in) :: & + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + real(pReal), intent(in) :: & + temperature !< temperature + integer(pInt), intent(in) :: & + instance, & of - type(tDislotwinMicrostructure), intent(in) :: & - mse - real(pReal), dimension(prm%totalNslip), intent(out) :: & + real(pReal), dimension(param(instance)%totalNslip), intent(in) :: & gdot_slip - real(pReal), dimension(prm%totalNtrans), intent(out) :: & + + real(pReal), dimension(param(instance)%totalNtrans), intent(out) :: & gdot_trans - real(pReal), dimension(prm%totalNtrans), optional, intent(out) :: & + real(pReal), dimension(param(instance)%totalNtrans), optional, intent(out) :: & dgdot_dtau_trans - real(pReal), dimension(3,3), intent(in) :: & - Mp - real(pReal), intent(in) :: & - temperature - real, dimension(prm%totalNtrans) :: & + real, dimension(param(instance)%totalNtrans) :: & tau, & - Ndot0_trans, & - stressRatio_r, & + Ndot0, & + stressRatio_s, & dgdot_dtau integer(pInt) :: i,s1,s2 + + associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) do i = 1_pInt, prm%totalNtrans tau(i) = math_mul33xx33(Mp,prm%Schmid_trans(1:3,1:3,i)) isFCC: if (prm%fccTwinTransNucleation) then s1=prm%fcc_twinNucleationSlipPair(1,i) s2=prm%fcc_twinNucleationSlipPair(2,i) - if (tau(i) < mse%tau_r_trans(i,of)) then - Ndot0_trans=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& - abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& - (prm%L0_trans*prm%burgers_slip(i))*& ! burgers_slip correct? + if (tau(i) < dst%tau_r_trans(i,of)) then + Ndot0=(abs(gdot_slip(s1))*(stt%rhoEdge(s2,of)+stt%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(stt%rhoEdge(s1,of)+stt%rhoEdgeDip(s1,of)))/& ! ToDo: MD: it would be more consistent to use shearrates from state + (prm%L0_trans*prm%burgers_slip(i))*& (1.0_pReal-exp(-prm%VcrossSlip/(kB*Temperature)*& - (mse%tau_r_trans(i,of)-tau))) + (dst%tau_r_trans(i,of)-tau))) else - Ndot0_trans=0.0_pReal + Ndot0=0.0_pReal end if else isFCC - Ndot0_trans=prm%Ndot0_trans(i) + Ndot0=prm%Ndot0_trans(i) endif isFCC enddo -! -! -! endif isFCCtrans -! dot%strainTransFraction(i,of) = f_unrotated * & -! mse%martensiteVolume(i,of)*Ndot0_trans*exp(-StressRatio_s) -! !* Dotstate for accumulated shear due to transformation -! !dot%accshear_trans(i,of) = dot%strainTransFraction(i,of) * & -! ! lattice_sheartrans(index_myfamily+i,ph) -! endif significantTransStress -! -! enddo transState -! -! -! significantStress: where(tau > tol_math_check) -! StressRatio_r = (mse%threshold_stress_twin(:,of)/tau)**prm%r -! gdot_twin = prm%shear_twin * mse%twinVolume(:,of) * Ndot0_twin*exp(-StressRatio_r) -! dgdot_dtau = ((gdot_twin*prm%r)/tau)*StressRatio_r -! else where significantStress -! gdot_twin = 0.0_pReal -! dgdot_dtau = 0.0_pReal -! end where significantStress -! -! if(present(dgdot_dtau_twin)) dgdot_dtau_twin = dgdot_dtau -! + + significantStress: where(tau > tol_math_check) + StressRatio_s = (dst%threshold_stress_trans(:,of)/tau)**prm%s + gdot_trans = dst%martensiteVolume(:,of) * Ndot0*exp(-StressRatio_s) + dgdot_dtau = (gdot_trans*prm%r/tau)*StressRatio_s + else where significantStress + gdot_trans = 0.0_pReal + dgdot_dtau = 0.0_pReal + end where significantStress + + end associate + + if(present(dgdot_dtau_trans)) dgdot_dtau_trans = dgdot_dtau + end subroutine kinetics_trans end module plastic_dislotwin From 7ce47930d1052d53c45486c3397e6c8fcd493737 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 22:00:18 +0100 Subject: [PATCH 289/372] test compatible with updated disloXX models --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index e03ef29af..0c34bbee9 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit e03ef29af51bf5b666a0765a137f773ca8af493d +Subproject commit 0c34bbee91b3d293382063126afe0abd22b44986 From 5630b389628508892216e988c85b44432fd2f6c8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 22:06:08 +0100 Subject: [PATCH 290/372] stress induced transformation was never really implemented --- src/plastic_dislotwin.f90 | 24 +++--------------------- 1 file changed, 3 insertions(+), 21 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index d85855577..e50dfea6f 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -39,7 +39,6 @@ module plastic_dislotwin threshold_stress_twin_ID, & resolved_stress_shearband_ID, & shear_rate_shearband_ID, & - stress_trans_fraction_ID, & strain_trans_fraction_ID end enum @@ -133,7 +132,6 @@ module plastic_dislotwin rhoEdgeDip, & accshear_slip, & twinFraction, & - stressTransFraction, & strainTransFraction, & whole end type tDislotwinState @@ -558,9 +556,6 @@ subroutine plastic_dislotwin_init outputID = shear_rate_shearband_ID outputSize = 6_pInt - case ('stress_trans_fraction') - outputID = stress_trans_fraction_ID - outputSize = prm%totalNtrans case ('strain_trans_fraction') outputID = strain_trans_fraction_ID outputSize = prm%totalNtrans @@ -580,7 +575,7 @@ subroutine plastic_dislotwin_init NipcMyPhase = count(material_phase == p) sizeDotState = int(size(['rho ','rhoDip ','accshearslip']),pInt) * prm%totalNslip & + int(size(['twinFraction']),pInt) * prm%totalNtwin & - + int(size(['stressTransFraction','strainTransFraction']),pInt) * prm%totalNtrans + + int(size(['strainTransFraction']),pInt) * prm%totalNtrans sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & @@ -619,12 +614,6 @@ subroutine plastic_dislotwin_init dot%twinFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTwinFrac - startIndex = endIndex + 1_pInt - endIndex=endIndex+prm%totalNtrans - stt%stressTransFraction=>plasticState(p)%state(startIndex:endIndex,:) - dot%stressTransFraction=>plasticState(p)%dotState(startIndex:endIndex,:) - plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTransFrac - startIndex = endIndex + 1_pInt endIndex=endIndex+prm%totalNtrans stt%strainTransFraction=>plasticState(p)%state(startIndex:endIndex,:) @@ -687,7 +676,6 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC) f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & - - sum(stt%stressTransFraction(1_pInt:prm%totalNtrans,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) homogenizedC = f_unrotated * prm%C66 @@ -697,7 +685,7 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC) enddo do i=1_pInt,prm%totalNtrans homogenizedC = homogenizedC & - +(stt%stressTransFraction(i,of)+stt%strainTransFraction(i,of))*prm%C66_trans(1:6,1:6,i) + + stt%strainTransFraction(i,of)*prm%C66_trans(1:6,1:6,i) enddo end associate @@ -765,7 +753,6 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & - - sum(stt%stressTransFraction(1_pInt:prm%totalNtrans,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) Lp = 0.0_pReal @@ -873,7 +860,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & - - sum(stt%stressTransFraction(1_pInt:prm%totalNtrans,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) call kinetics_slip(Mp,temperature,instance,of,gdot_slip) @@ -966,8 +952,7 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) mse => microstructure(instance)) sumf_twin = sum(stt%twinFraction(1:prm%totalNtwin,of)) - sumf_trans = sum(stt%stressTransFraction(1:prm%totalNtrans,of)) & - + sum(stt%strainTransFraction(1:prm%totalNtrans,of)) + sumf_trans = sum(stt%strainTransFraction(1:prm%totalNtrans,of)) sfe = prm%SFE_0K + prm%dSFE_dT * Temperature @@ -1153,9 +1138,6 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNtwin) = mse%threshold_stress_twin(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin - case (stress_trans_fraction_ID) - postResults(c+1_pInt:c+prm%totalNtrans) = 0.0_pReal - c = c + prm%totalNtrans case (strain_trans_fraction_ID) postResults(c+1_pInt:c+prm%totalNtrans) = stt%strainTransFraction(1_pInt:prm%totalNtrans,of) c = c + prm%totalNtrans From 6983718685a0250f23fda4518da81c8aac8081cd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 22:08:36 +0100 Subject: [PATCH 291/372] dst for "dependentState" --- src/plastic_dislotwin.f90 | 90 +++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index e50dfea6f..d334fd501 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -267,7 +267,7 @@ subroutine plastic_dislotwin_init associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)), & - mse => microstructure(phase_plasticityInstance(p)), & + dst => microstructure(phase_plasticityInstance(p)), & config => config_phase(p)) ! This data is read in already in lattice @@ -622,23 +622,23 @@ subroutine plastic_dislotwin_init dot%whole => plasticState(p)%dotState !ToDo: needed? - allocate(mse%invLambdaSlip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTwin (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaSlipTrans (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%mfp_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%threshold_stress_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(dst%invLambdaSlip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(dst%invLambdaSlipTwin (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(dst%invLambdaSlipTrans (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(dst%mfp_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) + allocate(dst%threshold_stress_slip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTwin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%mfp_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%threshold_stress_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%twinVolume (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%invLambdaTwin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%mfp_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%threshold_stress_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%twinVolume (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(mse%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(mse%mfp_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(mse%threshold_stress_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(mse%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(mse%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%mfp_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%threshold_stress_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally @@ -749,7 +749,7 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,Temperature,instance, 0, 1, 1 & ],pReal),[ 3,6]) - associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & @@ -854,7 +854,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) gdot_trans associate(prm => param(instance), stt => state(instance), & - dot => dotstate(instance), mse => microstructure(instance)) + dot => dotstate(instance), dst => microstructure(instance)) dot%whole(:,of) = 0.0_pReal @@ -867,14 +867,14 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) slipState: do i = 1_pInt, prm%totalNslip tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) - DotRhoMultiplication = abs(gdot_slip(i))/(prm%burgers_slip(i)*mse%mfp_slip(i,of)) + DotRhoMultiplication = abs(gdot_slip(i))/(prm%burgers_slip(i)*dst%mfp_slip(i,of)) EdgeDipMinDistance = prm%CEdgeDipMinDistance*prm%burgers_slip(i) significantSlipStress2: if (dEq0(tau)) then DotRhoDipFormation = 0.0_pReal else significantSlipStress2 EdgeDipDistance = (3.0_pReal*prm%mu*prm%burgers_slip(i))/(16.0_pReal*PI*abs(tau)) - if (EdgeDipDistance>mse%mfp_slip(i,of)) EdgeDipDistance = mse%mfp_slip(i,of) + if (EdgeDipDistance>dst%mfp_slip(i,of)) EdgeDipDistance = dst%mfp_slip(i,of) if (EdgeDipDistance param(instance),& stt => state(instance),& - mse => microstructure(instance)) + dst => microstructure(instance)) sumf_twin = sum(stt%twinFraction(1:prm%totalNtwin,of)) sumf_trans = sum(stt%strainTransFraction(1:prm%totalNtrans,of)) @@ -964,73 +964,73 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) !* 1/mean free distance between 2 forest dislocations seen by a moving dislocation forall (i = 1_pInt:prm%totalNslip) & - mse%invLambdaSlip(i,of) = & + dst%invLambdaSlip(i,of) = & sqrt(dot_product((stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of)),& prm%forestProjection(1:prm%totalNslip,i)))/prm%CLambdaSlip(i) !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation if (prm%totalNtwin > 0_pInt .and. prm%totalNslip > 0_pInt) & - mse%invLambdaSlipTwin(1_pInt:prm%totalNslip,of) = & + dst%invLambdaSlipTwin(1_pInt:prm%totalNslip,of) = & matmul(prm%interaction_SlipTwin,fOverStacksize)/(1.0_pReal-sumf_twin) !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin !ToDo: needed? if (prm%totalNtwin > 0_pInt) & - mse%invLambdaTwin(1_pInt:prm%totalNtwin,of) = matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) + dst%invLambdaTwin(1_pInt:prm%totalNtwin,of) = matmul(prm%interaction_TwinTwin,fOverStacksize)/(1.0_pReal-sumf_twin) !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation if (prm%totalNtrans > 0_pInt .and. prm%totalNslip > 0_pInt) & - mse%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & ! ToDo: does not work if Ntrans is not 12 + dst%invLambdaSlipTrans(1_pInt:prm%totalNslip,of) = & ! ToDo: does not work if Ntrans is not 12 matmul(prm%interaction_SlipTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) !ToDo: needed? if (prm%totalNtrans > 0_pInt) & - mse%invLambdaTrans(1_pInt:prm%totalNtrans,of) = matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) + dst%invLambdaTrans(1_pInt:prm%totalNtrans,of) = matmul(prm%interaction_TransTrans,ftransOverLamellarSize)/(1.0_pReal-sumf_trans) !* mean free path between 2 obstacles seen by a moving dislocation do i = 1_pInt,prm%totalNslip if ((prm%totalNtwin > 0_pInt) .or. (prm%totalNtrans > 0_pInt)) then ! ToDo: This is too simplified - mse%mfp_slip(i,of) = & + dst%mfp_slip(i,of) = & prm%GrainSize/(1.0_pReal+prm%GrainSize*& - (mse%invLambdaSlip(i,of) + mse%invLambdaSlipTwin(i,of) + mse%invLambdaSlipTrans(i,of))) + (dst%invLambdaSlip(i,of) + dst%invLambdaSlipTwin(i,of) + dst%invLambdaSlipTrans(i,of))) else - mse%mfp_slip(i,of) = prm%GrainSize & - / (1.0_pReal+prm%GrainSize*mse%invLambdaSlip(i,of)) !!!!!! correct? + dst%mfp_slip(i,of) = prm%GrainSize & + / (1.0_pReal+prm%GrainSize*dst%invLambdaSlip(i,of)) !!!!!! correct? endif enddo !* mean free path between 2 obstacles seen by a growing twin/martensite - mse%mfp_twin(:,of) = prm%Cmfptwin*prm%GrainSize/ (1.0_pReal+prm%GrainSize*mse%invLambdaTwin(:,of)) - mse%mfp_trans(:,of) = prm%Cmfptrans*prm%GrainSize/(1.0_pReal+prm%GrainSize*mse%invLambdaTrans(:,of)) + dst%mfp_twin(:,of) = prm%Cmfptwin*prm%GrainSize/ (1.0_pReal+prm%GrainSize*dst%invLambdaTwin(:,of)) + dst%mfp_trans(:,of) = prm%Cmfptrans*prm%GrainSize/(1.0_pReal+prm%GrainSize*dst%invLambdaTrans(:,of)) !* threshold stress for dislocation motion - forall (i = 1_pInt:prm%totalNslip) mse%threshold_stress_slip(i,of) = & + forall (i = 1_pInt:prm%totalNslip) dst%threshold_stress_slip(i,of) = & prm%mu*prm%burgers_slip(i)*& sqrt(dot_product(stt%rhoEdge(1_pInt:prm%totalNslip,of)+stt%rhoEdgeDip(1_pInt:prm%totalNslip,of),& prm%interaction_SlipSlip(i,1:prm%totalNslip))) !* threshold stress for growing twin/martensite if(prm%totalNtwin == prm%totalNslip) & - mse%threshold_stress_twin(:,of) = prm%Cthresholdtwin* & + dst%threshold_stress_twin(:,of) = prm%Cthresholdtwin* & (sfe/(3.0_pReal*prm%burgers_twin)+ 3.0_pReal*prm%burgers_twin*prm%mu/ & (prm%L0_twin*prm%burgers_slip)) ! slip burgers here correct? if(prm%totalNtrans == prm%totalNslip) & - mse%threshold_stress_trans(:,of) = prm%Cthresholdtrans* & + dst%threshold_stress_trans(:,of) = prm%Cthresholdtrans* & (sfe/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& (prm%L0_trans*prm%burgers_slip) + prm%transStackHeight*prm%deltaG/ (3.0_pReal*prm%burgers_trans) ) ! final volume after growth - mse%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*mse%mfp_twin(:,of)**2.0_pReal - mse%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsizePerTransSystem*mse%mfp_trans(:,of)**2.0_pReal + dst%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*dst%mfp_twin(:,of)**2.0_pReal + dst%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsizePerTransSystem*dst%mfp_trans(:,of)**2.0_pReal !* equilibrium separation of partial dislocations (twin) x0 = prm%mu*prm%burgers_twin**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) - mse%tau_r_twin(:,of) = prm%mu*prm%burgers_twin/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0) + dst%tau_r_twin(:,of) = prm%mu*prm%burgers_twin/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0) !* equilibrium separation of partial dislocations (trans) x0 = prm%mu*prm%burgers_trans**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) - mse%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) + dst%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) end associate @@ -1063,7 +1063,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe integer(pInt) :: & o,c,j - associate(prm => param(instance), stt => state(instance), mse => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) c = 0_pInt @@ -1083,7 +1083,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear_slip(1_pInt:prm%totalNslip,of) c = c + prm%totalNslip case (mfp_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = mse%mfp_slip(1_pInt:prm%totalNslip,of) + postResults(c+1_pInt:c+prm%totalNslip) = dst%mfp_slip(1_pInt:prm%totalNslip,of) c = c + prm%totalNslip case (resolved_stress_slip_ID) do j = 1_pInt, prm%totalNslip @@ -1091,13 +1091,13 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe enddo c = c + prm%totalNslip case (threshold_stress_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = mse%threshold_stress_slip(1_pInt:prm%totalNslip,of) + postResults(c+1_pInt:c+prm%totalNslip) = dst%threshold_stress_slip(1_pInt:prm%totalNslip,of) c = c + prm%totalNslip case (edge_dipole_distance_ID) do j = 1_pInt, prm%totalNslip postResults(c+j) = (3.0_pReal*prm%mu*prm%burgers_slip(j)) & / (16.0_pReal*PI*abs(math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)))) - postResults(c+j)=min(postResults(c+j),mse%mfp_slip(j,of)) + postResults(c+j)=min(postResults(c+j),dst%mfp_slip(j,of)) ! postResults(c+j)=max(postResults(c+j),& ! plasticState(ph)%state(4*ns+2*nt+2*nr+j, of)) enddo @@ -1127,7 +1127,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNtwin) = stt%twinFraction(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin case (mfp_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = mse%mfp_twin(1_pInt:prm%totalNtwin,of) + postResults(c+1_pInt:c+prm%totalNtwin) = dst%mfp_twin(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin case (resolved_stress_twin_ID) do j = 1_pInt, prm%totalNtwin @@ -1135,7 +1135,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe enddo c = c + prm%totalNtwin case (threshold_stress_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = mse%threshold_stress_twin(1_pInt:prm%totalNtwin,of) + postResults(c+1_pInt:c+prm%totalNtwin) = dst%threshold_stress_twin(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin case (strain_trans_fraction_ID) From 35972fbb8e19fb0f33864aa8192291f0b82344ba Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 22:12:27 +0100 Subject: [PATCH 292/372] output would need to be store on demand --- src/plastic_dislotwin.f90 | 41 +-------------------------------------- 1 file changed, 1 insertion(+), 40 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index d334fd501..5e1235a94 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -532,9 +532,6 @@ subroutine plastic_dislotwin_init case ('threshold_stress_slip') outputID= merge(threshold_stress_slip_ID,undefined_ID,prm%totalNslip > 0_pInt) outputSize = prm%totalNslip - case ('edge_dipole_distance') - outputID = merge(edge_dipole_distance_ID,undefined_ID,prm%totalNslip > 0_pInt) - outputSize = prm%totalNslip case ('twin_fraction') outputID = merge(twin_fraction_ID,undefined_ID,prm%totalNtwin >0_pInt) @@ -549,13 +546,6 @@ subroutine plastic_dislotwin_init outputID = merge(threshold_stress_twin_ID,undefined_ID,prm%totalNtwin >0_pInt) outputSize = prm%totalNtwin - case ('resolved_stress_shearband') - outputID = resolved_stress_shearband_ID - outputSize = 6_pInt - case ('shear_rate_shearband','shearrate_shearband') - outputID = shear_rate_shearband_ID - outputSize = 6_pInt - case ('strain_trans_fraction') outputID = strain_trans_fraction_ID outputSize = prm%totalNtrans @@ -1093,36 +1083,7 @@ function plastic_dislotwin_postResults(Mp,Temperature,instance,of) result(postRe case (threshold_stress_slip_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%threshold_stress_slip(1_pInt:prm%totalNslip,of) c = c + prm%totalNslip - case (edge_dipole_distance_ID) - do j = 1_pInt, prm%totalNslip - postResults(c+j) = (3.0_pReal*prm%mu*prm%burgers_slip(j)) & - / (16.0_pReal*PI*abs(math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,j)))) - postResults(c+j)=min(postResults(c+j),dst%mfp_slip(j,of)) - ! postResults(c+j)=max(postResults(c+j),& - ! plasticState(ph)%state(4*ns+2*nt+2*nr+j, of)) - enddo - c = c + prm%totalNslip - ! case (resolved_stress_shearband_ID) - ! do j = 1_pInt,6_pInt ! loop over all shearband families - ! postResults(c+j) = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) - ! enddo - ! c = c + 6_pInt - ! case (shear_rate_shearband_ID) - ! do j = 1_pInt,6_pInt ! loop over all shearbands - ! tau = dot_product(Tstar_v,sbSv(1:6,j,ipc,ip,el)) - ! if (abs(tau) < tol_math_check) then - ! StressRatio_p = 0.0_pReal - ! StressRatio_pminus1 = 0.0_pReal - ! else - ! StressRatio_p = (abs(tau)/prm%sbResistance)**prm%pShearBand - ! StressRatio_pminus1 = (abs(tau)/prm%sbResistance)**(prm%pShearBand-1.0_pReal) - ! endif - ! BoltzmannRatio = prm%sbQedge/(kB*Temperature) - ! DotGamma0 = prm%sbVelocity - ! postResults(c+j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**prm%qShearBand)*& - ! sign(1.0_pReal,tau) - ! enddo - ! c = c + 6_pInt + case (twin_fraction_ID) postResults(c+1_pInt:c+prm%totalNtwin) = stt%twinFraction(1_pInt:prm%totalNtwin,of) c = c + prm%totalNtwin From 3fb99b06cab566e2b0eedc28369999df5d683d7f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 22:13:45 +0100 Subject: [PATCH 293/372] avoid calculation in output routine --- src/plastic_disloUCLA.f90 | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index eea064158..f987ee75b 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -28,8 +28,7 @@ module plastic_disloUCLA shearrate_ID, & accumulatedshear_ID, & mfp_ID, & - thresholdstress_ID, & - dipoledistance_ID + thresholdstress_ID end enum type, private :: tParameters @@ -312,8 +311,6 @@ subroutine plastic_disloUCLA_init() outputID = merge(mfp_ID,undefined_ID,prm%totalNslip>0_pInt) case ('threshold_stress','threshold_stress_slip') outputID = merge(thresholdstress_ID,undefined_ID,prm%totalNslip>0_pInt) - case ('edge_dipole_distance') - outputID = merge(dipoleDistance_ID,undefined_ID,prm%totalNslip>0_pInt) end select @@ -560,16 +557,6 @@ function plastic_disloUCLA_postResults(Mp,Temperature,instance,of) result(postRe postResults(c+1_pInt:c+prm%totalNslip) = dst%mfp(1_pInt:prm%totalNslip, of) case (thresholdstress_ID) postResults(c+1_pInt:c+prm%totalNslip) = dst%threshold_stress(1_pInt:prm%totalNslip,of) - case (dipoleDistance_ID) ! ToDo: Discuss required changes with Franz - do i = 1_pInt, prm%totalNslip - if (dNeq0(abs(math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i))))) then - postResults(c+i) = (3.0_pReal*prm%mu*prm%burgers(i)) & - / (16.0_pReal*pi*abs(math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)))) - else - postResults(c+i) = huge(1.0_pReal) - endif - postResults(c+i)=min(postResults(c+i),dst%mfp(i,of)) - enddo end select From ef06e7c4fd519d518d9f2b049fbe642108334178 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 27 Jan 2019 23:36:34 +0100 Subject: [PATCH 294/372] cleaning --- src/plastic_dislotwin.f90 | 41 +++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 23 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 5e1235a94..d9312ae18 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -86,7 +86,7 @@ module plastic_dislotwin Ndot0_trans, & !< trans nucleation rate [1/m³s] for each trans system twinsize, & !< twin thickness [m] for each twin system CLambdaSlip, & !< Adj. parameter for distance between 2 forest dislocations for each slip system - lamellarsizePerTransSystem, & !< martensite lamellar thickness [m] for each trans system and instance + lamellarsize, & !< martensite lamellar thickness [m] for each trans system and instance p, & !< p-exponent in glide velocity q, & !< q-exponent in glide velocity r, & !< r-exponent in twin nucleation rate @@ -132,16 +132,15 @@ module plastic_dislotwin rhoEdgeDip, & accshear_slip, & twinFraction, & - strainTransFraction, & - whole + strainTransFraction end type tDislotwinState type, private :: tDislotwinMicrostructure real(pReal), allocatable, dimension(:,:) :: & invLambdaSlip, & invLambdaSlipTwin, & - invLambdaTwin, & invLambdaSlipTrans, & + invLambdaTwin, & invLambdaTrans, & mfp_slip, & mfp_twin, & @@ -151,8 +150,8 @@ module plastic_dislotwin threshold_stress_trans, & twinVolume, & martensiteVolume, & - tau_r_twin, & !< stress to bring partial close together for each twin system and instance - tau_r_trans !< stress to bring partial close together for each trans system and instance + tau_r_twin, & !< stress to bring partial close together for each twin system and instance + tau_r_trans !< stress to bring partial close together for each trans system and instance end type tDislotwinMicrostructure !-------------------------------------------------------------------------------------------------- @@ -414,12 +413,12 @@ subroutine plastic_dislotwin_init prm%Ndot0_trans = config%getFloats('ndot0_trans') prm%Ndot0_trans = math_expand(prm%Ndot0_trans,prm%Ntrans) endif - prm%lamellarsizePerTransSystem = config%getFloats('lamellarsize') - prm%lamellarsizePerTransSystem = math_expand(prm%lamellarsizePerTransSystem,prm%Ntrans) + prm%lamellarsize = config%getFloats('lamellarsize') + prm%lamellarsize = math_expand(prm%lamellarsize,prm%Ntrans) prm%s = config%getFloats('s_trans',defaultVal=[0.0_pReal]) prm%s = math_expand(prm%s,prm%Ntrans) else - allocate(prm%lamellarsizePerTransSystem(0)) + allocate(prm%lamellarsize(0)) allocate(prm%burgers_trans(0)) endif @@ -610,8 +609,6 @@ subroutine plastic_dislotwin_init dot%strainTransFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTransFrac - dot%whole => plasticState(p)%dotState !ToDo: needed? - allocate(dst%invLambdaSlip (prm%totalNslip, NipcMyPhase),source=0.0_pReal) allocate(dst%invLambdaSlipTwin (prm%totalNslip, NipcMyPhase),source=0.0_pReal) allocate(dst%invLambdaSlipTrans (prm%totalNslip, NipcMyPhase),source=0.0_pReal) @@ -621,15 +618,16 @@ subroutine plastic_dislotwin_init allocate(dst%invLambdaTwin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%mfp_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(dst%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) + allocate(dst%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) !* equilibrium separation of partial dislocations (twin) allocate(dst%twinVolume (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(dst%mfp_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(dst%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + allocate(dst%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) !* equilibrium separation of partial dislocations (trans) allocate(dst%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally end associate @@ -846,8 +844,6 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) associate(prm => param(instance), stt => state(instance), & dot => dotstate(instance), dst => microstructure(instance)) - dot%whole(:,of) = 0.0_pReal - f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) @@ -948,7 +944,7 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) !* rescaled volume fraction for topology fOverStacksize = stt%twinFraction(1_pInt:prm%totalNtwin,of)/prm%twinsize !ToDo: this is per system - ftransOverLamellarSize = sumf_trans/prm%lamellarsizePerTransSystem !ToDo: But this not ... + ftransOverLamellarSize = sumf_trans/prm%lamellarsize !ToDo: But this not ... !Todo: Physically ok, but naming could be adjusted @@ -1010,16 +1006,15 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) (sfe/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& (prm%L0_trans*prm%burgers_slip) + prm%transStackHeight*prm%deltaG/ (3.0_pReal*prm%burgers_trans) ) - ! final volume after growth - dst%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*dst%mfp_twin(:,of)**2.0_pReal - dst%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsizePerTransSystem*dst%mfp_trans(:,of)**2.0_pReal - !* equilibrium separation of partial dislocations (twin) - x0 = prm%mu*prm%burgers_twin**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) + dst%twinVolume(:,of) = (PI/4.0_pReal)*prm%twinsize*dst%mfp_twin(:,of)**2.0_pReal + dst%martensiteVolume(:,of) = (PI/4.0_pReal)*prm%lamellarsize*dst%mfp_trans(:,of)**2.0_pReal + + + x0 = prm%mu*prm%burgers_twin**2.0_pReal/(SFE*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) dst%tau_r_twin(:,of) = prm%mu*prm%burgers_twin/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0) - !* equilibrium separation of partial dislocations (trans) - x0 = prm%mu*prm%burgers_trans**2.0_pReal/(sfe*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) + x0 = prm%mu*prm%burgers_trans**2.0_pReal/(SFE*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu) dst%tau_r_trans(:,of) = prm%mu*prm%burgers_trans/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0) end associate From 2c2d04d0fa54052a1566b062c5efb9dcb1e509ff Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 28 Jan 2019 00:33:51 +0100 Subject: [PATCH 295/372] [skip ci] updated version information after successful test of v2.0.2-1521-g7ce47930 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index a51af2ff4..4296d10f3 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1519-g453323d1 +v2.0.2-1521-g7ce47930 From 26fbf5084d7df8c6fba1d22682d387cecd81b655 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 28 Jan 2019 07:52:01 +0100 Subject: [PATCH 296/372] [skip ci] avoid space in file names --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 0c34bbee9..beb9682ff 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 0c34bbee91b3d293382063126afe0abd22b44986 +Subproject commit beb9682fff7d4d6c65aba12ffd04c7441dc6ba6b From 19958b35c1845f1706a0dd44009a965099231eba Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 28 Jan 2019 10:22:39 +0100 Subject: [PATCH 297/372] [skip ci] updated version information after successful test of v2.0.2-1540-ge2582a8d --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 4296d10f3..3801ac74e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1521-g7ce47930 +v2.0.2-1540-ge2582a8d From 8c2d6400b1802f5e8313b06c031d0840e51a8a48 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 28 Jan 2019 11:28:46 +0100 Subject: [PATCH 298/372] cleaning --- src/crystallite.f90 | 97 +++++++++++++++------------------------------ 1 file changed, 31 insertions(+), 66 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index af69b1727..0d3eef17e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -69,7 +69,7 @@ module crystallite 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_invFi, & !< inverse of current intermediate def grad 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 @@ -78,12 +78,11 @@ module crystallite real(pReal), dimension(:,:,:,:,:,:,:), allocatable, public :: & crystallite_dPdF !< current individual dPdF per grain (end of converged time step) logical, dimension(:,:,:), allocatable, public :: & - crystallite_requested !< flag to request crystallite calculation - logical, dimension(:,:,:), allocatable, public, protected :: & - crystallite_converged !< convergence flag + crystallite_requested !< used by upper level (homogenization) to request crystallite calculation logical, dimension(:,:,:), allocatable, private :: & - crystallite_localPlasticity, & !< indicates this grain to have purely local constitutive law - crystallite_todo !< flag to indicate need for further computation + 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, & @@ -999,13 +998,11 @@ function crystallite_postResults(ipc, ip, el) mySize, & n - crystID = microstructure_crystallite(mesh_element(4,el)) crystallite_postResults = 0.0_pReal - c = 0_pInt - crystallite_postResults(c+1) = real(crystallite_sizePostResults(crystID),pReal) ! size of results from cryst - c = c + 1_pInt + crystallite_postResults(1) = real(crystallite_sizePostResults(crystID),pReal) ! header-like information (length) + c = 1_pInt do o = 1_pInt,crystallite_Noutput(crystID) mySize = 0_pInt @@ -1612,12 +1609,6 @@ subroutine integrateStateFPI() singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo at start of state integration' -#endif - - ! --+>> PREGUESS FOR STATE <<+-- call update_dotState(1.0_pReal) call update_state(1.0_pReal) @@ -1807,11 +1798,6 @@ subroutine integrateStateFPI() !$OMP ENDDO !$OMP END PARALLEL -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & - ' grains converged after state integration #', NiterationState -#endif ! --- NON-LOCAL CONVERGENCE CHECK --- @@ -1820,20 +1806,11 @@ subroutine integrateStateFPI() crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged endif -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) then - write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & - ' grains converged after non-local check' - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_todo(:,:,:)), & - ' grains todo after state integration #', NiterationState - endif -#endif ! --- CHECK IF DONE WITH INTEGRATION --- - doneWithIntegration = .true. elemLoop: do e = eIter(1),eIter(2) - do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then doneWithIntegration = .false. exit elemLoop @@ -1843,6 +1820,29 @@ subroutine integrateStateFPI() enddo crystalliteLooping + contains + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate the damping for correction of state and dot state +!-------------------------------------------------------------------------------------------------- + real(pReal) pure function damper(current,previous,previous2) + + implicit none + real(pReal), dimension(:), intent(in) ::& + current, previous, previous2 + + real(pReal) :: dot_prod12, dot_prod22 + + dot_prod12 = dot_product(current - previous, previous - previous2) + dot_prod22 = dot_product(current - previous2, previous - previous2) + if (dot_prod22 > 0.0_pReal .and. (dot_prod12 < 0.0_pReal .or. dot_product(current,previous) < 0.0_pReal)) then + damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + else + damper = 1.0_pReal + endif + + end function damper + end subroutine integrateStateFPI @@ -2119,17 +2119,6 @@ end subroutine integrateStateAdaptiveEuler subroutine integrateStateRK4() use, intrinsic :: & IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif use mesh, only: & mesh_element, & mesh_NcpElems @@ -2331,10 +2320,6 @@ subroutine integrateStateRKCK45() singleRun ! flag indicating computation for single (g,i,e) triple eIter = FEsolving_execElem(1:2) -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',1 -#endif ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- do e = eIter(1),eIter(2) @@ -2483,22 +2468,6 @@ subroutine integrateStateRKCK45() abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) enddo - -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt& - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i3,1x,i3,/)') '<< CRYST >> updateState at el ip ipc ',e,i,g - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & - relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', & - plasticState(p)%dotState(1:mySizePlasticDotState,cc) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & - plasticState(p)%state(1:mySizePlasticDotState,cc) - endif -#endif endif enddo; enddo; enddo !$OMP ENDDO @@ -2511,10 +2480,6 @@ subroutine integrateStateRKCK45() ! --- nonlocal convergence check --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' ! if not requesting Integration of just a single IP -#endif if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged From 95cb404f81c7fd88c4a880f6f9a3454e14e74b13 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 28 Jan 2019 11:49:24 +0100 Subject: [PATCH 299/372] further cleaning --- src/crystallite.f90 | 174 +++++++++----------------------------------- 1 file changed, 33 insertions(+), 141 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 0d3eef17e..1b97f74c2 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1538,17 +1538,6 @@ end function integrateStress subroutine integrateStateFPI() use, intrinsic :: & IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level,& - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif use numerics, only: & nState, & rTol_crystalliteState @@ -1580,11 +1569,6 @@ subroutine integrateStateFPI() mySource, & mySizePlasticDotState, & ! size of dot states mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration real(pReal) :: & dot_prod12, & dot_prod22, & @@ -1598,22 +1582,11 @@ subroutine integrateStateFPI() tempSourceState logical :: & converged, & - singleRun, & ! flag indicating computation for single (g,i,e) triple doneWithIntegration - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - ! --+>> PREGUESS FOR STATE <<+-- - call update_dotState(1.0_pReal) - call update_state(1.0_pReal) - - ! --+>> STATE LOOP <<+-- + call update_dotState(1.0_pReal) + call update_state(1.0_pReal) NiterationState = 0_pInt doneWithIntegration = .false. @@ -1655,8 +1628,10 @@ subroutine integrateStateFPI() !$OMP& plasticStateResiduum,sourceStateResiduum, & !$OMP& plasticStatedamper,sourceStateDamper, & !$OMP& tempPlasticState,tempSourceState,converged,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) +if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e) c = phasememberAt(g,i,e) @@ -1737,20 +1712,6 @@ subroutine integrateStateFPI() * (1.0_pReal - sourceStateDamper) enddo -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g - write(6,'(a,f6.1,/)') '<< CRYST >> plasticstatedamper ',plasticStatedamper - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',& - abs(plasticStateResiduum(1:mySizePlasticDotState)) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> abstol dotstate',plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> reltol dotstate',rTol_crystalliteState* & - abs(tempPlasticState(1:mySizePlasticDotState)) - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state',tempPlasticState(1:mySizePlasticDotState) - endif -#endif ! --- converged ? --- converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & @@ -1780,7 +1741,9 @@ subroutine integrateStateFPI() ! --- STATE JUMP --- !$OMP DO - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) !$OMP FLUSH(crystallite_todo) if (crystallite_todo(g,i,e) .and. crystallite_converged(g,i,e)) then ! converged and still alive... crystallite_todo(g,i,e) = stateJump(g,i,e) @@ -1801,7 +1764,7 @@ subroutine integrateStateFPI() ! --- NON-LOCAL CONVERGENCE CHECK --- - if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(plasticState(:)%nonlocal)) then ! if not requesting Integration of just a single IP if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged endif @@ -1809,17 +1772,19 @@ subroutine integrateStateFPI() ! --- CHECK IF DONE WITH INTEGRATION --- doneWithIntegration = .true. - elemLoop: do e = eIter(1),eIter(2) - do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then doneWithIntegration = .false. - exit elemLoop + exit endif enddo; enddo - enddo elemLoop + enddo enddo crystalliteLooping - + + contains !-------------------------------------------------------------------------------------------------- @@ -1850,40 +1815,9 @@ end subroutine integrateStateFPI !> @brief integrate stress, and state with 1st order explicit Euler method !-------------------------------------------------------------------------------------------------- subroutine integrateStateEuler() - use, intrinsic :: & - IEEE_arithmetic - use mesh, only: & - mesh_element, & - mesh_NcpElems use material, only: & - phase_Nsources, & - homogenization_Ngrains - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure - + plasticState implicit none - integer(pInt) :: & - e, & ! element index in element loop - i, & ! integration point index in ip loop - g ! grain index in grain loop - - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - logical :: & - singleRun ! flag indicating computation for single (g,i,e) triple - - -eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) call update_dotState(1.0_pReal) call update_State(1.0_pReal) @@ -1894,7 +1828,7 @@ eIter = FEsolving_execElem(1:2) ! --- CHECK NON-LOCAL CONVERGENCE --- - if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(plasticState(:)%nonlocal)) then if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged endif @@ -1908,17 +1842,6 @@ end subroutine integrateStateEuler subroutine integrateStateAdaptiveEuler() use, intrinsic :: & IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif use numerics, only: & rTol_crystalliteState use mesh, only: & @@ -1949,12 +1872,7 @@ subroutine integrateStateAdaptiveEuler() mySource, & mySizePlasticDotState, & ! size of dot states mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & +real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & plasticStateResiduum, & ! residuum from evolution in micrstructure relPlasticStateResiduum ! relative residuum from evolution in microstructure @@ -1966,18 +1884,7 @@ subroutine integrateStateAdaptiveEuler() logical :: & converged, & - NaN, & - singleRun ! flag indicating computation for single (g,i,e) triple - - - ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + NaN plasticStateResiduum = 0.0_pReal @@ -1995,7 +1902,9 @@ subroutine integrateStateAdaptiveEuler() ! --- STATE UPDATE (EULER INTEGRATION) --- !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) c = phasememberAt(g,i,e) @@ -2037,7 +1946,9 @@ subroutine integrateStateAdaptiveEuler() !$OMP END SINGLE !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) c = phasememberAt(g,i,e) @@ -2066,21 +1977,6 @@ subroutine integrateStateAdaptiveEuler() sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) enddo -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & - .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) - write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & - relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) & - - 2.0_pReal * plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / crystallite_subdt(g,i,e) ! calculate former dotstate from higher order solution and state residuum - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) - endif -#endif - ! --- converged ? --- converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & rTol_crystalliteState .or. & @@ -2102,14 +1998,11 @@ subroutine integrateStateAdaptiveEuler() ! --- NONLOCAL CONVERGENCE CHECK --- -#ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' -#endif - if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - + if (any(plasticState(:)%nonlocal)) then + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif end subroutine integrateStateAdaptiveEuler @@ -2222,10 +2115,9 @@ subroutine integrateStateRK4() ! --- CHECK NONLOCAL CONVERGENCE --- - if (.not. singleRun) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) then ! any non-local not yet converged (or broken)... + if (any(plasticState(:)%nonlocal)) then + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif endif end subroutine integrateStateRK4 From 8a2524b5d26aa81cb74148304607c82b6e4310f4 Mon Sep 17 00:00:00 2001 From: Franz Roters Date: Mon, 28 Jan 2019 15:56:05 +0100 Subject: [PATCH 300/372] requiredShape outdated: use requiredSize --- src/homogenization_RGC.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index ef81043eb..8ac76606a 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -177,15 +177,15 @@ subroutine homogenization_RGC_init() endif #endif - prm%Nconstituents = config%getInts('clustersize',requiredShape=[3]) + prm%Nconstituents = config%getInts('clustersize',requiredSize=3) if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config%getFloat('scalingparameter') prm%ciAlpha = config%getFloat('overproportionality') - prm%dAlpha = config%getFloats('grainsize', requiredShape=[3]) - prm%angles = config%getFloats('clusterorientation',requiredShape=[3]) + prm%dAlpha = config%getFloats('grainsize', requiredSize=3) + prm%angles = config%getFloats('clusterorientation',requiredSize=3) outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) From 80cfc23f3655ea1f366191b0d952e15af52b3606 Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 28 Jan 2019 21:16:42 +0100 Subject: [PATCH 301/372] [skip ci] updated version information after successful test of v2.0.2-1604-g8a2524b5 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 3801ac74e..59daee05a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1540-ge2582a8d +v2.0.2-1604-g8a2524b5 From b62232022b4cad4187e65d0427c1680d05b6a100 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 00:27:58 +0100 Subject: [PATCH 302/372] polishing --- src/crystallite.f90 | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 1b97f74c2..19727af7d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -69,7 +69,7 @@ module crystallite 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 + 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 @@ -666,14 +666,14 @@ function crystallite_stress() ! 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) ! iterate over IPs of this element to be processed + 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) ! iterate over IPs of this element to be processed + 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) & @@ -844,17 +844,16 @@ subroutine crystallite_stressTangent() !-------------------------------------------------------------------------------------------------- ! assemble dPdF temp_33_1 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & - math_mul33x33(math_6toSym33(crystallite_Tstar_v(1:6,c,i,e)), & - transpose(crystallite_invFp(1:3,1:3,c,i,e)))) + math_mul33x33(math_6toSym33(crystallite_Tstar_v(1:6,c,i,e)), & + transpose(crystallite_invFp(1:3,1:3,c,i,e)))) temp_33_2 = math_mul33x33(math_6toSym33(crystallite_Tstar_v(1:6,c,i,e)), & - transpose(crystallite_invFp(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), & - crystallite_invFp(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), & - crystallite_invFp(1:3,1:3,c,i,e)), & - math_6toSym33(crystallite_Tstar_v(1:6,c,i,e))) + crystallite_invFp(1:3,1:3,c,i,e)), & + math_6toSym33(crystallite_Tstar_v(1:6,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 crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) enddo @@ -1628,10 +1627,10 @@ subroutine integrateStateFPI() !$OMP& plasticStateResiduum,sourceStateResiduum, & !$OMP& plasticStatedamper,sourceStateDamper, & !$OMP& tempPlasticState,tempSourceState,converged,p,c) - do e = FEsolving_execElem(1),FEsolving_execElem(2) + do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) -if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e) c = phasememberAt(g,i,e) @@ -1787,9 +1786,9 @@ if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then contains -!-------------------------------------------------------------------------------------------------- -!> @brief calculate the damping for correction of state and dot state -!-------------------------------------------------------------------------------------------------- + !-------------------------------------------------------------------------------------------------- + !> @brief calculate the damping for correction of state and dot state + !-------------------------------------------------------------------------------------------------- real(pReal) pure function damper(current,previous,previous2) implicit none From 2f9a571b9626682a7708fb3c960f763dacedf4ee Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 00:38:18 +0100 Subject: [PATCH 303/372] no need for 2 variables --- src/crystallite.f90 | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 19727af7d..358dacea8 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1571,8 +1571,7 @@ subroutine integrateStateFPI() real(pReal) :: & dot_prod12, & dot_prod22, & - plasticStateDamper, & ! damper for integration of state - sourceStateDamper + stateDamper real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & plasticStateResiduum, & tempPlasticState @@ -1625,7 +1624,7 @@ subroutine integrateStateFPI() !$OMP DO PRIVATE(dot_prod12,dot_prod22, & !$OMP& mySizePlasticDotState,mySizeSourceDotState, & !$OMP& plasticStateResiduum,sourceStateResiduum, & - !$OMP& plasticStatedamper,sourceStateDamper, & + !$OMP& stateDamper, & !$OMP& tempPlasticState,tempSourceState,converged,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) @@ -1646,9 +1645,9 @@ subroutine integrateStateFPI() .and. ( dot_prod12 < 0.0_pReal & .or. dot_product(plasticState(p)%dotState(:,c), & plasticState(p)%previousDotState(:,c)) < 0.0_pReal) ) then - plasticStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + stateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) else - plasticStateDamper = 1.0_pReal + stateDamper = 1.0_pReal endif ! --- get residui --- @@ -1656,9 +1655,9 @@ subroutine integrateStateFPI() plasticStateResiduum(1:mySizePlasticDotState) = & plasticState(p)%state(1:mySizePlasticDotState,c) & - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * plasticStateDamper & + - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * stateDamper & + plasticState(p)%previousDotState(1:mySizePlasticDotState,c) & - * (1.0_pReal - plasticStateDamper)) * crystallite_subdt(g,i,e) + * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- tempPlasticState(1:mySizePlasticDotState) = & @@ -1667,9 +1666,9 @@ subroutine integrateStateFPI() ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) - plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * plasticStateDamper & + plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & + plasticState(p)%previousDotState(:,c) & - * (1.0_pReal - plasticStateDamper) + * (1.0_pReal - stateDamper) do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState @@ -1686,18 +1685,18 @@ subroutine integrateStateFPI() .and. ( dot_prod12 < 0.0_pReal & .or. dot_product(sourceState(p)%p(mySource)%dotState(:,c), & sourceState(p)%p(mySource)%previousDotState(:,c)) < 0.0_pReal) ) then - sourceStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + stateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) else - sourceStateDamper = 1.0_pReal + stateDamper = 1.0_pReal endif ! --- get residui --- mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState sourceStateResiduum(1:mySizeSourceDotState,mySource) = & sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * sourceStateDamper & + - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * stateDamper & + sourceState(p)%p(mySource)%previousDotState(1:mySizeSourceDotState,c) & - * (1.0_pReal - sourceStateDamper)) * crystallite_subdt(g,i,e) + * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- tempSourceState(1:mySizeSourceDotState,mySource) = & @@ -1706,9 +1705,9 @@ subroutine integrateStateFPI() ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) sourceState(p)%p(mySource)%dotState(:,c) = & - sourceState(p)%p(mySource)%dotState(:,c) * sourceStateDamper & + sourceState(p)%p(mySource)%dotState(:,c) * stateDamper & + sourceState(p)%p(mySource)%previousDotState(:,c) & - * (1.0_pReal - sourceStateDamper) + * (1.0_pReal - stateDamper) enddo From 2cf44f4060f64d20001fc545e7a419c50509a7ef Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 00:39:44 +0100 Subject: [PATCH 304/372] shorter --- src/crystallite.f90 | 69 ++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 35 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 358dacea8..0ae050173 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1565,7 +1565,6 @@ subroutine integrateStateFPI() p, & c, & s, & - mySource, & mySizePlasticDotState, & ! size of dot states mySizeSourceDotState real(pReal) :: & @@ -1670,43 +1669,43 @@ subroutine integrateStateFPI() + plasticState(p)%previousDotState(:,c) & * (1.0_pReal - stateDamper) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - dot_prod12 = dot_product( sourceState(p)%p(mySource)%dotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState (:,c), & - sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c)) - dot_prod22 = dot_product( sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c), & - sourceState(p)%p(mySource)%previousDotState (:,c) & - - sourceState(p)%p(mySource)%previousDotState2(:,c)) + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + dot_prod12 = dot_product( sourceState(p)%p(s)%dotState (:,c) & + - sourceState(p)%p(s)%previousDotState (:,c), & + sourceState(p)%p(s)%previousDotState (:,c) & + - sourceState(p)%p(s)%previousDotState2(:,c)) + dot_prod22 = dot_product( sourceState(p)%p(s)%previousDotState (:,c) & + - sourceState(p)%p(s)%previousDotState2(:,c), & + sourceState(p)%p(s)%previousDotState (:,c) & + - sourceState(p)%p(s)%previousDotState2(:,c)) if ( dot_prod22 > 0.0_pReal & .and. ( dot_prod12 < 0.0_pReal & - .or. dot_product(sourceState(p)%p(mySource)%dotState(:,c), & - sourceState(p)%p(mySource)%previousDotState(:,c)) < 0.0_pReal) ) then + .or. dot_product(sourceState(p)%p(s)%dotState(:,c), & + sourceState(p)%p(s)%previousDotState(:,c)) < 0.0_pReal) ) then stateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) else stateDamper = 1.0_pReal endif ! --- get residui --- - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource) = & - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & - - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & - - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * stateDamper & - + sourceState(p)%p(mySource)%previousDotState(1:mySizeSourceDotState,c) & + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,s) = & + sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) & + - sourceState(p)%p(s)%subState0(1:mySizeSourceDotState,c) & + - ( sourceState(p)%p(s)%dotState(1:mySizeSourceDotState,c) * stateDamper & + + sourceState(p)%p(s)%previousDotState(1:mySizeSourceDotState,c) & * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- - tempSourceState(1:mySizeSourceDotState,mySource) = & - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & - - sourceStateResiduum(1:mySizeSourceDotState,mySource) ! need to copy to local variable, since we cant flush a pointer in openmp + tempSourceState(1:mySizeSourceDotState,s) = & + sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) & + - sourceStateResiduum(1:mySizeSourceDotState,s) ! need to copy to local variable, since we cant flush a pointer in openmp ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) - sourceState(p)%p(mySource)%dotState(:,c) = & - sourceState(p)%p(mySource)%dotState(:,c) * stateDamper & - + sourceState(p)%p(mySource)%previousDotState(:,c) & + sourceState(p)%p(s)%dotState(:,c) = & + sourceState(p)%p(s)%dotState(:,c) * stateDamper & + + sourceState(p)%p(s)%previousDotState(:,c) & * (1.0_pReal - stateDamper) enddo @@ -1716,22 +1715,22 @@ subroutine integrateStateFPI() plasticState(p)%aTolState(1:mySizePlasticDotState) & .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState converged = converged .and. & - all( abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState) & - .or. abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & - rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,mySource))) + all( abs(sourceStateResiduum(1:mySizeSourceDotState,s)) < & + sourceState(p)%p(s)%aTolState(1:mySizeSourceDotState) & + .or. abs(sourceStateResiduum(1:mySizeSourceDotState,s)) < & + rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,s))) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition plasticState(p)%state(1:mySizePlasticDotState,c) = & tempPlasticState(1:mySizePlasticDotState) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & - tempSourceState(1:mySizeSourceDotState,mySource) + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) = & + tempSourceState(1:mySizeSourceDotState,s) enddo endif enddo; enddo; enddo From ee586dfa0c0a99e7e93556a6ff356b9552cb702e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 00:46:57 +0100 Subject: [PATCH 305/372] avoid code duplication --- src/crystallite.f90 | 47 +++++++-------------------------------------- 1 file changed, 7 insertions(+), 40 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 0ae050173..ad12b455e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1568,8 +1568,6 @@ subroutine integrateStateFPI() mySizePlasticDotState, & ! size of dot states mySizeSourceDotState real(pReal) :: & - dot_prod12, & - dot_prod22, & stateDamper real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & plasticStateResiduum, & @@ -1620,8 +1618,7 @@ subroutine integrateStateFPI() !$OMP PARALLEL ! --- UPDATE STATE --- - !$OMP DO PRIVATE(dot_prod12,dot_prod22, & - !$OMP& mySizePlasticDotState,mySizeSourceDotState, & + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState, & !$OMP& plasticStateResiduum,sourceStateResiduum, & !$OMP& stateDamper, & !$OMP& tempPlasticState,tempSourceState,converged,p,c) @@ -1632,23 +1629,9 @@ subroutine integrateStateFPI() p = phaseAt(g,i,e) c = phasememberAt(g,i,e) - dot_prod12 = dot_product( plasticState(p)%dotState (:,c) & - - plasticState(p)%previousDotState (:,c), & - plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c)) - dot_prod22 = dot_product( plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c), & - plasticState(p)%previousDotState (:,c) & - - plasticState(p)%previousDotState2(:,c)) - if ( dot_prod22 > 0.0_pReal & - .and. ( dot_prod12 < 0.0_pReal & - .or. dot_product(plasticState(p)%dotState(:,c), & - plasticState(p)%previousDotState(:,c)) < 0.0_pReal) ) then - stateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) - else - stateDamper = 1.0_pReal - endif - ! --- get residui --- + StateDamper = damper(plasticState(p)%dotState (:,c), & + plasticState(p)%previousDotState (:,c), & + plasticState(p)%previousDotState2(:,c)) mySizePlasticDotState = plasticState(p)%sizeDotState plasticStateResiduum(1:mySizePlasticDotState) = & @@ -1670,25 +1653,9 @@ subroutine integrateStateFPI() * (1.0_pReal - stateDamper) do s = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState - dot_prod12 = dot_product( sourceState(p)%p(s)%dotState (:,c) & - - sourceState(p)%p(s)%previousDotState (:,c), & - sourceState(p)%p(s)%previousDotState (:,c) & - - sourceState(p)%p(s)%previousDotState2(:,c)) - dot_prod22 = dot_product( sourceState(p)%p(s)%previousDotState (:,c) & - - sourceState(p)%p(s)%previousDotState2(:,c), & - sourceState(p)%p(s)%previousDotState (:,c) & - - sourceState(p)%p(s)%previousDotState2(:,c)) - - if ( dot_prod22 > 0.0_pReal & - .and. ( dot_prod12 < 0.0_pReal & - .or. dot_product(sourceState(p)%p(s)%dotState(:,c), & - sourceState(p)%p(s)%previousDotState(:,c)) < 0.0_pReal) ) then - stateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) - else - stateDamper = 1.0_pReal - endif - ! --- get residui --- + StateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & + sourceState(p)%p(s)%previousDotState (:,c), & + sourceState(p)%p(s)%previousDotState2(:,c)) mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState sourceStateResiduum(1:mySizeSourceDotState,s) = & sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) & From 9b77bdd122c893412b2d39dd4129c2da4ee6545c Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 29 Jan 2019 04:24:32 +0100 Subject: [PATCH 306/372] [skip ci] updated version information after successful test of v2.0.2-1608-gcd3cbf47 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 59daee05a..31608bd97 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1604-g8a2524b5 +v2.0.2-1608-gcd3cbf47 From 918860ab386d32839fc4a9bab798089bb42618c8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 06:14:58 +0100 Subject: [PATCH 307/372] easier to store atomic volume instead of scaling factor --- src/plastic_dislotwin.f90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index d9312ae18..2ee2a40e1 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -46,7 +46,6 @@ module plastic_dislotwin real(pReal) :: & mu, & nu, & - CAtomicVolume, & !< atomic volume in Bugers vector unit D0, & !< prefactor for self-diffusion coefficient Qsd, & !< activation energy for dislocation climb GrainSize, & ! system prm%rho0 = math_expand(prm%rho0, prm%Nslip) @@ -318,7 +319,8 @@ subroutine plastic_dislotwin_init prm%p = math_expand(prm%p, prm%Nslip) prm%q = math_expand(prm%q, prm%Nslip) prm%B = math_expand(prm%B, prm%Nslip) - prm%tau_peierls = math_expand(prm%tau_peierls, prm%Nslip) + prm%tau_peierls = math_expand(prm%tau_peierls, prm%Nslip) + prm%atomicVolume = math_expand(prm%atomicVolume,prm%Nslip) ! sanity checks if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//'rho0 ' @@ -450,7 +452,6 @@ subroutine plastic_dislotwin_init prm%aTolTwinFrac = config%getFloat('atol_twinfrac', defaultVal=0.0_pReal) prm%aTolTransFrac = config%getFloat('atol_transfrac', defaultVal=0.0_pReal) - prm%CAtomicVolume = config%getFloat('catomicvolume') prm%GrainSize = config%getFloat('grainsize') @@ -470,7 +471,7 @@ subroutine plastic_dislotwin_init !if (Ndot0PerTwinFamily(f,p) < 0.0_pReal) & ! call IO_error(211_pInt,el=p,ext_msg='ndot0_twin ('//PLASTICITY_DISLOTWIN_label//')') - if (prm%CAtomicVolume <= 0.0_pReal) & + if (any(prm%atomicVolume <= 0.0_pReal)) & call IO_error(211_pInt,el=p,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOTWIN_label//')') if (prm%D0 <= 0.0_pReal) & call IO_error(211_pInt,el=p,ext_msg='D0 ('//PLASTICITY_DISLOTWIN_label//')') @@ -830,7 +831,7 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) integer(pInt) :: i real(pReal) :: f_unrotated,& - EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,& + EdgeDipMinDistance,VacancyDiffusion,& EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & DotRhoDipFormation,DotRhoMultiplication,DotRhoEdgeEdgeAnnihilation, & tau @@ -859,11 +860,11 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) significantSlipStress2: if (dEq0(tau)) then DotRhoDipFormation = 0.0_pReal else significantSlipStress2 - EdgeDipDistance = (3.0_pReal*prm%mu*prm%burgers_slip(i))/(16.0_pReal*PI*abs(tau)) + EdgeDipDistance = 3.0_pReal*prm%mu*prm%burgers_slip(i)/(16.0_pReal*PI*abs(tau)) if (EdgeDipDistance>dst%mfp_slip(i,of)) EdgeDipDistance = dst%mfp_slip(i,of) if (EdgeDipDistance Date: Tue, 29 Jan 2019 06:41:27 +0100 Subject: [PATCH 308/372] sanity checks in more sensible order --- src/plastic_dislotwin.f90 | 113 ++++++++++++++++++-------------------- 1 file changed, 52 insertions(+), 61 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 2ee2a40e1..f201e90e0 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -150,8 +150,8 @@ module plastic_dislotwin threshold_stress_trans, & twinVolume, & martensiteVolume, & - tau_r_twin, & !< stress to bring partial close together for each twin system and instance - tau_r_trans !< stress to bring partial close together for each trans system and instance + tau_r_twin, & !< stress to bring partials close together (twin) + tau_r_trans !< stress to bring partials close together (trans) end type tDislotwinMicrostructure !-------------------------------------------------------------------------------------------------- @@ -269,6 +269,10 @@ subroutine plastic_dislotwin_init dst => microstructure(phase_plasticityInstance(p)), & config => config_phase(p)) + prm%aTolRho = config%getFloat('atol_rho', defaultVal=0.0_pReal) + prm%aTolTwinFrac = config%getFloat('atol_twinfrac', defaultVal=0.0_pReal) + prm%aTolTransFrac = config%getFloat('atol_transfrac', defaultVal=0.0_pReal) + ! This data is read in already in lattice prm%mu = lattice_mu(p) prm%nu = lattice_nu(p) @@ -307,6 +311,8 @@ subroutine plastic_dislotwin_init defaultVal=[(0.0_pReal, i=1,size(prm%Nslip))]) ! Deprecated prm%CEdgeDipMinDistance = config%getFloat('cedgedipmindistance') + prm%D0 = config%getFloat('d0') + prm%Qsd = config%getFloat('qsd') prm%atomicVolume = config%getFloat('catomicvolume') * prm%burgers_slip**3.0_pReal ! expand: family => system @@ -323,16 +329,18 @@ subroutine plastic_dislotwin_init prm%atomicVolume = math_expand(prm%atomicVolume,prm%Nslip) ! sanity checks - if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//'rho0 ' - if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//'rhoDip0 ' - if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//'v0 ' - if (any(prm%burgers_slip <= 0.0_pReal)) extmsg = trim(extmsg)//'burgers_slip ' - if (any(prm%Qedge <= 0.0_pReal)) extmsg = trim(extmsg)//'Qedge ' - if (any(prm%CLambdaSlip <= 0.0_pReal)) extmsg = trim(extmsg)//'CLambdaSlip ' - if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//'B ' - if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//'tau_peierls ' - if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//'p ' - if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//'q ' + if ( prm%D0 <= 0.0_pReal) extmsg = trim(extmsg)//' D0' + if ( prm%Qsd <= 0.0_pReal) extmsg = trim(extmsg)//' Qsd' + if (any(prm%rho0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho0' + if (any(prm%rhoDip0 < 0.0_pReal)) extmsg = trim(extmsg)//' rhoDip0' + if (any(prm%v0 < 0.0_pReal)) extmsg = trim(extmsg)//' v0' + if (any(prm%burgers_slip <= 0.0_pReal)) extmsg = trim(extmsg)//' burgers_slip' + if (any(prm%Qedge <= 0.0_pReal)) extmsg = trim(extmsg)//' Qedge' + if (any(prm%CLambdaSlip <= 0.0_pReal)) extmsg = trim(extmsg)//' CLambdaSlip' + if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//' B' + if (any(prm%tau_peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' + if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//' p' + if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//' q' else slipActive allocate(prm%burgers_slip(0)) @@ -445,66 +453,48 @@ subroutine plastic_dislotwin_init config%getFloats('interaction_sliptrans'), & config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%totalNtrans > 12_pInt) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if ntrans is [6,6] - endif - - - prm%aTolRho = config%getFloat('atol_rho', defaultVal=0.0_pReal) - prm%aTolTwinFrac = config%getFloat('atol_twinfrac', defaultVal=0.0_pReal) - prm%aTolTransFrac = config%getFloat('atol_transfrac', defaultVal=0.0_pReal) - - prm%GrainSize = config%getFloat('grainsize') - - - prm%D0 = config%getFloat('d0') - prm%Qsd = config%getFloat('qsd') - prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') ! Deprecated - if (config%keyExists('dipoleformationfactor')) call IO_error(1,ext_msg='use /nodipoleformation/') - prm%dipoleformation = .not. config%keyExists('/nodipoleformation/') - prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal) + endif + +!-------------------------------------------------------------------------------------------------- +! shearband related parameters + prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal) if (prm%sbVelocity > 0.0_pReal) then prm%sbResistance = config%getFloat('shearbandresistance') - prm%sbQedge = config%getFloat('qedgepersbsystem') - prm%pShearBand = config%getFloat('p_shearband') - prm%qShearBand = config%getFloat('q_shearband') + prm%sbQedge = config%getFloat('qedgepersbsystem') + prm%pShearBand = config%getFloat('p_shearband') + prm%qShearBand = config%getFloat('q_shearband') + + ! sanity checks + if (prm%sbResistance < 0.0_pReal) extmsg = trim(extmsg)//' shearbandresistance' + if (prm%sbQedge < 0.0_pReal) extmsg = trim(extmsg)//' qedgepersbsystem' + if (prm%pShearBand <= 0.0_pReal) extmsg = trim(extmsg)//' p_shearband' + if (prm%qShearBand <= 0.0_pReal) extmsg = trim(extmsg)//' q_shearband' endif + + + prm%GrainSize = config%getFloat('grainsize') + prm%SolidSolutionStrength = config%getFloat('solidsolutionstrength') ! Deprecated + + if (config%keyExists('dipoleformationfactor')) call IO_error(1,ext_msg='use /nodipoleformation/') + prm%dipoleformation = .not. config%keyExists('/nodipoleformation/') + + !if (Ndot0PerTwinFamily(f,p) < 0.0_pReal) & ! call IO_error(211_pInt,el=p,ext_msg='ndot0_twin ('//PLASTICITY_DISLOTWIN_label//')') if (any(prm%atomicVolume <= 0.0_pReal)) & call IO_error(211_pInt,el=p,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOTWIN_label//')') - if (prm%D0 <= 0.0_pReal) & - call IO_error(211_pInt,el=p,ext_msg='D0 ('//PLASTICITY_DISLOTWIN_label//')') - if (prm%Qsd <= 0.0_pReal) & - call IO_error(211_pInt,el=p,ext_msg='Qsd ('//PLASTICITY_DISLOTWIN_label//')') if (prm%totalNtwin > 0_pInt) then - if (dEq0(prm%SFE_0K) .and. & - dEq0(prm%dSFE_dT) .and. & - lattice_structure(p) == LATTICE_fcc_ID) & - call IO_error(211_pInt,el=p,ext_msg='SFE0K ('//PLASTICITY_DISLOTWIN_label//')') if (prm%aTolRho <= 0.0_pReal) & call IO_error(211_pInt,el=p,ext_msg='aTolRho ('//PLASTICITY_DISLOTWIN_label//')') if (prm%aTolTwinFrac <= 0.0_pReal) & call IO_error(211_pInt,el=p,ext_msg='aTolTwinFrac ('//PLASTICITY_DISLOTWIN_label//')') endif if (prm%totalNtrans > 0_pInt) then - if (dEq0(prm%SFE_0K) .and. & - dEq0(prm%dSFE_dT) .and. & - lattice_structure(p) == LATTICE_fcc_ID) & - call IO_error(211_pInt,el=p,ext_msg='SFE0K ('//PLASTICITY_DISLOTWIN_label//')') if (prm%aTolTransFrac <= 0.0_pReal) & call IO_error(211_pInt,el=p,ext_msg='aTolTransFrac ('//PLASTICITY_DISLOTWIN_label//')') endif - !if (prm%sbResistance < 0.0_pReal) & - ! call IO_error(211_pInt,el=p,ext_msg='sbResistance ('//PLASTICITY_DISLOTWIN_label//')') - !if (prm%sbVelocity < 0.0_pReal) & - ! call IO_error(211_pInt,el=p,ext_msg='sbVelocity ('//PLASTICITY_DISLOTWIN_label//')') - !if (prm%sbVelocity > 0.0_pReal .and. & - ! prm%pShearBand <= 0.0_pReal) & - ! call IO_error(211_pInt,el=p,ext_msg='pShearBand ('//PLASTICITY_DISLOTWIN_label//')') - if (prm%sbVelocity > 0.0_pReal .and. & - prm%qShearBand <= 0.0_pReal) & - call IO_error(211_pInt,el=p,ext_msg='qShearBand ('//PLASTICITY_DISLOTWIN_label//')') outputs = config%getStrings('(output)', defaultVal=emptyStringArray) allocate(prm%outputID(0)) @@ -599,13 +589,13 @@ subroutine plastic_dislotwin_init plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) startIndex = endIndex + 1_pInt - endIndex=endIndex+prm%totalNtwin + endIndex = endIndex + prm%totalNtwin stt%twinFraction=>plasticState(p)%state(startIndex:endIndex,:) dot%twinFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTwinFrac startIndex = endIndex + 1_pInt - endIndex=endIndex+prm%totalNtrans + endIndex = endIndex + prm%totalNtrans stt%strainTransFraction=>plasticState(p)%state(startIndex:endIndex,:) dot%strainTransFraction=>plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolTransFrac @@ -619,13 +609,13 @@ subroutine plastic_dislotwin_init allocate(dst%invLambdaTwin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%mfp_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) - allocate(dst%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) !* equilibrium separation of partial dislocations (twin) + allocate(dst%tau_r_twin (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%twinVolume (prm%totalNtwin, NipcMyPhase),source=0.0_pReal) allocate(dst%invLambdaTrans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(dst%mfp_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(dst%threshold_stress_trans(prm%totalNtrans,NipcMyPhase),source=0.0_pReal) - allocate(dst%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) !* equilibrium separation of partial dislocations (trans) + allocate(dst%tau_r_trans (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) allocate(dst%martensiteVolume (prm%totalNtrans,NipcMyPhase),source=0.0_pReal) @@ -815,8 +805,9 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) tol_math_check, & dEq0 use math, only: & + math_clip, & math_mul33xx33, & - pi + PI use material, only: & plasticState @@ -940,7 +931,7 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) sumf_twin = sum(stt%twinFraction(1:prm%totalNtwin,of)) sumf_trans = sum(stt%strainTransFraction(1:prm%totalNtrans,of)) - sfe = prm%SFE_0K + prm%dSFE_dT * Temperature + SFE = prm%SFE_0K + prm%dSFE_dT * Temperature !* rescaled volume fraction for topology fOverStacksize = stt%twinFraction(1_pInt:prm%totalNtwin,of)/prm%twinsize !ToDo: this is per system @@ -999,11 +990,11 @@ subroutine plastic_dislotwin_dependentState(temperature,instance,of) !* threshold stress for growing twin/martensite if(prm%totalNtwin == prm%totalNslip) & dst%threshold_stress_twin(:,of) = prm%Cthresholdtwin* & - (sfe/(3.0_pReal*prm%burgers_twin)+ 3.0_pReal*prm%burgers_twin*prm%mu/ & + (SFE/(3.0_pReal*prm%burgers_twin)+ 3.0_pReal*prm%burgers_twin*prm%mu/ & (prm%L0_twin*prm%burgers_slip)) ! slip burgers here correct? if(prm%totalNtrans == prm%totalNslip) & dst%threshold_stress_trans(:,of) = prm%Cthresholdtrans* & - (sfe/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& + (SFE/(3.0_pReal*prm%burgers_trans) + 3.0_pReal*prm%burgers_trans*prm%mu/& (prm%L0_trans*prm%burgers_slip) + prm%transStackHeight*prm%deltaG/ (3.0_pReal*prm%burgers_trans) ) From c10922de2b4631f274597222d67cedf4c0aff65d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 06:52:55 +0100 Subject: [PATCH 309/372] vector notation easier to read --- src/plastic_dislotwin.f90 | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index f201e90e0..c96fb9c29 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -822,11 +822,13 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) integer(pInt) :: i real(pReal) :: f_unrotated,& - EdgeDipMinDistance,VacancyDiffusion,& + VacancyDiffusion,& EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & - DotRhoDipFormation,DotRhoMultiplication,DotRhoEdgeEdgeAnnihilation, & + DotRhoDipFormation,DotRhoEdgeEdgeAnnihilation, & tau real(pReal), dimension(plasticState(instance)%Nslip) :: & + EdgeDipMinDistance, & + DotRhoMultiplication, & gdot_slip real(pReal), dimension(plasticState(instance)%Ntwin) :: & gdot_twin @@ -839,23 +841,25 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) f_unrotated = 1.0_pReal & - sum(stt%twinFraction(1_pInt:prm%totalNtwin,of)) & - sum(stt%strainTransFraction(1_pInt:prm%totalNtrans,of)) + VacancyDiffusion = prm%D0*exp(-prm%Qsd/(kB*Temperature)) call kinetics_slip(Mp,temperature,instance,of,gdot_slip) + dot%accshear_slip(:,of) = abs(gdot_slip) + + DotRhoMultiplication = abs(gdot_slip)/(prm%burgers_slip*dst%mfp_slip(:,of)) + EdgeDipMinDistance = prm%CEdgeDipMinDistance*prm%burgers_slip slipState: do i = 1_pInt, prm%totalNslip tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) - DotRhoMultiplication = abs(gdot_slip(i))/(prm%burgers_slip(i)*dst%mfp_slip(i,of)) - EdgeDipMinDistance = prm%CEdgeDipMinDistance*prm%burgers_slip(i) - significantSlipStress2: if (dEq0(tau)) then DotRhoDipFormation = 0.0_pReal else significantSlipStress2 EdgeDipDistance = 3.0_pReal*prm%mu*prm%burgers_slip(i)/(16.0_pReal*PI*abs(tau)) if (EdgeDipDistance>dst%mfp_slip(i,of)) EdgeDipDistance = dst%mfp_slip(i,of) - if (EdgeDipDistance Date: Tue, 29 Jan 2019 07:06:16 +0100 Subject: [PATCH 310/372] bugfix: missing initialization --- src/crystallite.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index ad12b455e..da603a2bd 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -854,6 +854,7 @@ subroutine crystallite_stressTangent() crystallite_invFp(1:3,1:3,c,i,e)), & math_6toSym33(crystallite_Tstar_v(1:6,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 crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) enddo From 4967ac0132beec639857d80b2adb01403319603f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 07:22:56 +0100 Subject: [PATCH 311/372] need to check for significant stress only once --- src/plastic_dislotwin.f90 | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index c96fb9c29..7e5272dc2 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -852,19 +852,30 @@ subroutine plastic_dislotwin_dotState(Mp,Temperature,instance,of) slipState: do i = 1_pInt, prm%totalNslip tau = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) - significantSlipStress2: if (dEq0(tau)) then + significantSlipStress: if (dEq0(tau)) then DotRhoDipFormation = 0.0_pReal - else significantSlipStress2 + DotRhoEdgeDipClimb = 0.0_pReal + else significantSlipStress EdgeDipDistance = 3.0_pReal*prm%mu*prm%burgers_slip(i)/(16.0_pReal*PI*abs(tau)) - if (EdgeDipDistance>dst%mfp_slip(i,of)) EdgeDipDistance = dst%mfp_slip(i,of) - if (EdgeDipDistance Date: Tue, 29 Jan 2019 00:54:02 +0100 Subject: [PATCH 312/372] further simplifications --- src/crystallite.f90 | 34 ++++++++++++---------------------- 1 file changed, 12 insertions(+), 22 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index da603a2bd..ab99156d0 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1861,18 +1861,13 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & ! contribution to state and relative residui and from Euler integration call update_dotState(1.0_pReal) - !$OMP PARALLEL - - - ! --- STATE UPDATE (EULER INTEGRATION) --- - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - 0.5_pReal & @@ -1895,28 +1890,24 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & enddo endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO + call update_deltaState call update_dependentState call update_stress(1.0_pReal) call update_dotState(1.0_pReal) - !$OMP PARALLEL - ! --- ERROR ESTIMATE FOR STATE (HEUN METHOD) --- - - !$OMP SINGLE relPlasticStateResiduum = 0.0_pReal relSourceStateResiduum = 0.0_pReal - !$OMP END SINGLE - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) + + !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + ! --- contribution of heun step to absolute residui --- mySizePlasticDotState = plasticState(p)%sizeDotState plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & @@ -1958,8 +1949,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definitionem endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO ! --- NONLOCAL CONVERGENCE CHECK --- From 1e4da6fbdb17f8a1ed70c0474755f4da8a8f70fc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 05:11:29 +0100 Subject: [PATCH 313/372] nonlocal convergence check in function --- src/crystallite.f90 | 108 ++++++++++++++++++-------------------------- 1 file changed, 44 insertions(+), 64 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index ab99156d0..14a54492a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1542,8 +1542,7 @@ subroutine integrateStateFPI() nState, & rTol_crystalliteState use mesh, only: & - mesh_element, & - mesh_NcpElems + mesh_element use material, only: & plasticState, & sourceState, & @@ -1727,12 +1726,7 @@ subroutine integrateStateFPI() !$OMP END PARALLEL - ! --- NON-LOCAL CONVERGENCE CHECK --- - - if (any(plasticState(:)%nonlocal)) then ! if not requesting Integration of just a single IP - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif + if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck ! --- CHECK IF DONE WITH INTEGRATION --- @@ -1777,26 +1771,21 @@ end subroutine integrateStateFPI !-------------------------------------------------------------------------------------------------- -!> @brief integrate stress, and state with 1st order explicit Euler method +!> @brief integrate state with 1st order explicit Euler method !-------------------------------------------------------------------------------------------------- subroutine integrateStateEuler() use material, only: & plasticState + implicit none call update_dotState(1.0_pReal) - call update_State(1.0_pReal) + call update_state(1.0_pReal) call update_deltaState call update_dependentState call update_stress(1.0_pReal) call setConvergenceFlag - - ! --- CHECK NON-LOCAL CONVERGENCE --- - - if (any(plasticState(:)%nonlocal)) then - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif + if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck end subroutine integrateStateEuler @@ -1848,8 +1837,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & relSourceStateResiduum ! relative residuum from evolution in microstructure logical :: & - converged, & - NaN + converged plasticStateResiduum = 0.0_pReal @@ -1951,13 +1939,8 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & enddo; enddo; enddo !$OMP END PARALLEL DO + if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck - ! --- NONLOCAL CONVERGENCE CHECK --- - - if (any(plasticState(:)%nonlocal)) then - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif end subroutine integrateStateAdaptiveEuler @@ -2038,7 +2021,9 @@ subroutine integrateStateRK4() !$OMP PARALLEL !$OMP DO PRIVATE(p,c) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) c = phasememberAt(g,i,e) @@ -2066,14 +2051,9 @@ subroutine integrateStateRK4() enddo + call setConvergenceFlag - - ! --- CHECK NONLOCAL CONVERGENCE --- - - if (any(plasticState(:)%nonlocal)) then - if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) ) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged - endif + if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck end subroutine integrateStateRK4 @@ -2148,11 +2128,7 @@ subroutine integrateStateRKCK45() mySource, & mySizePlasticDotState, & ! size of dot States mySizeSourceDotState - integer(pInt), dimension(2) :: & - eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: & - iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & @@ -2163,18 +2139,7 @@ subroutine integrateStateRKCK45() homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & sourceStateResiduum, & ! residuum from evolution in microstructure relSourceStateResiduum ! relative residuum from evolution in microstructure - logical :: & - singleRun ! flag indicating computation for single (g,i,e) triple - eIter = FEsolving_execElem(1:2) - - ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) call update_dotState(1.0_pReal) @@ -2188,7 +2153,9 @@ subroutine integrateStateRKCK45() !$OMP PARALLEL !$OMP DO PRIVATE(p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) @@ -2201,7 +2168,9 @@ subroutine integrateStateRKCK45() !$OMP ENDDO !$OMP DO PRIVATE(p,cc,n) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) @@ -2239,7 +2208,9 @@ subroutine integrateStateRKCK45() relSourceStateResiduum = 0.0_pReal !$OMP PARALLEL !$OMP DO PRIVATE(p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) @@ -2252,7 +2223,9 @@ subroutine integrateStateRKCK45() !$OMP ENDDO !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) @@ -2288,7 +2261,9 @@ subroutine integrateStateRKCK45() ! --- relative residui and state convergence --- !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) - do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) @@ -2324,15 +2299,25 @@ subroutine integrateStateRKCK45() call update_dependentState call update_stress(1.0_pReal) call setConvergenceFlag - - - ! --- nonlocal convergence check --- - if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... - crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck end subroutine integrateStateRKCK45 +!-------------------------------------------------------------------------------------------------- +!> @brief sets convergence flag for nonlocal calculations +!> @detail one non-converged nonlocal sets all other nonlocals to non-converged to trigger cut back +!-------------------------------------------------------------------------------------------------- +subroutine nonlocalConvergenceCheck() + + implicit none + + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + where( .not. crystallite_localPlasticity) crystallite_converged = .false. + +end subroutine nonlocalConvergenceCheck + + !-------------------------------------------------------------------------------------------------- !> @brief Sets convergence flag based on "todo": every point that survived the integration (todo is ! still .true. is considered as converged @@ -2361,11 +2346,6 @@ end subroutine setConvergenceFlag !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- subroutine update_stress(timeFraction) - use material, only: & - plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt implicit none real(pReal), intent(in) :: & From 4a69032637141f7856e2bf65a72bfc0579ef66ed Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 05:16:56 +0100 Subject: [PATCH 314/372] better readable --- src/crystallite.f90 | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 14a54492a..8ae1df5af 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2065,17 +2065,6 @@ end subroutine integrateStateRK4 subroutine integrateStateRKCK45() use, intrinsic :: & IEEE_arithmetic -#ifdef DEBUG - use debug, only: & - debug_e, & - debug_i, & - debug_g, & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective -#endif use numerics, only: & rTol_crystalliteState use mesh, only: & @@ -2098,11 +2087,11 @@ subroutine integrateStateRKCK45() implicit none real(pReal), dimension(5,5), parameter :: & A = reshape([& - .2_pReal, .075_pReal, .3_pReal, -11.0_pReal/54.0_pReal, 1631.0_pReal/55296.0_pReal, & - .0_pReal, .225_pReal, -.9_pReal, 2.5_pReal, 175.0_pReal/512.0_pReal, & - .0_pReal, .0_pReal, 1.2_pReal, -70.0_pReal/27.0_pReal, 575.0_pReal/13824.0_pReal, & + .2_pReal, .075_pReal, .3_pReal, -11.0_pReal/54.0_pReal, 1631.0_pReal/55296.0_pReal, & + .0_pReal, .225_pReal, -.9_pReal, 2.5_pReal, 175.0_pReal/512.0_pReal, & + .0_pReal, .0_pReal, 1.2_pReal, -70.0_pReal/27.0_pReal, 575.0_pReal/13824.0_pReal, & .0_pReal, .0_pReal, .0_pReal, 35.0_pReal/27.0_pReal, 44275.0_pReal/110592.0_pReal, & - .0_pReal, .0_pReal, .0_pReal, .0_pReal, 253.0_pReal/4096.0_pReal], & + .0_pReal, .0_pReal, .0_pReal, .0_pReal, 253.0_pReal/4096.0_pReal], & [5,5], order=[2,1]) !< coefficients in Butcher tableau (used for preliminary integration in stages 2 to 6) real(pReal), dimension(6), parameter :: & From a24d8b86bf44255e5fc9d29879d92eac6bafab59 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 05:20:16 +0100 Subject: [PATCH 315/372] convergence of plastic state can be done earlier --- src/crystallite.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 8ae1df5af..475d7dc2a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1651,6 +1651,13 @@ subroutine integrateStateFPI() plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & + plasticState(p)%previousDotState(:,c) & * (1.0_pReal - stateDamper) + + converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState) & + .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) + + plasticState(p)%state(1:mySizePlasticDotState,c) = tempPlasticState(1:mySizePlasticDotState) do s = 1_pInt, phase_Nsources(p) StateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & @@ -1676,12 +1683,6 @@ subroutine integrateStateFPI() * (1.0_pReal - stateDamper) enddo - - ! --- converged ? --- - converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState) & - .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) do s = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState converged = converged .and. & @@ -1692,8 +1693,7 @@ subroutine integrateStateFPI() enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition - plasticState(p)%state(1:mySizePlasticDotState,c) = & - tempPlasticState(1:mySizePlasticDotState) + do s = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) = & From 41832fb554335c1ae0624fc310c749d40cfa542f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 05:39:01 +0100 Subject: [PATCH 316/372] no need for two variables only resulted in confusing code --- src/crystallite.f90 | 67 ++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 475d7dc2a..74dfd3731 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1565,8 +1565,7 @@ subroutine integrateStateFPI() p, & c, & s, & - mySizePlasticDotState, & ! size of dot states - mySizeSourceDotState + sizeDotState real(pReal) :: & stateDamper real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & @@ -1618,7 +1617,7 @@ subroutine integrateStateFPI() !$OMP PARALLEL ! --- UPDATE STATE --- - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState, & + !$OMP DO PRIVATE(sizeDotState, & !$OMP& plasticStateResiduum,sourceStateResiduum, & !$OMP& stateDamper, & !$OMP& tempPlasticState,tempSourceState,converged,p,c) @@ -1633,18 +1632,18 @@ subroutine integrateStateFPI() plasticState(p)%previousDotState (:,c), & plasticState(p)%previousDotState2(:,c)) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState) = & - plasticState(p)%state(1:mySizePlasticDotState,c) & - - plasticState(p)%subState0(1:mySizePlasticDotState,c) & - - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * stateDamper & - + plasticState(p)%previousDotState(1:mySizePlasticDotState,c) & + sizeDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:sizeDotState) = & + plasticState(p)%state(1:sizeDotState,c) & + - plasticState(p)%subState0(1:sizeDotState,c) & + - ( plasticState(p)%dotState(1:sizeDotState,c) * stateDamper & + + plasticState(p)%previousDotState(1:sizeDotState,c) & * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- - tempPlasticState(1:mySizePlasticDotState) = & - plasticState(p)%state(1:mySizePlasticDotState,c) & - - plasticStateResiduum(1:mySizePlasticDotState) ! need to copy to local variable, since we cant flush a pointer in openmp + tempPlasticState(1:sizeDotState) = & + plasticState(p)%state(1:sizeDotState,c) & + - plasticStateResiduum(1:sizeDotState) ! need to copy to local variable, since we cant flush a pointer in openmp ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) @@ -1652,29 +1651,29 @@ subroutine integrateStateFPI() + plasticState(p)%previousDotState(:,c) & * (1.0_pReal - stateDamper) - converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState) & - .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & - rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) + converged = all( abs(plasticStateResiduum(1:sizeDotState)) < & + plasticState(p)%aTolState(1:sizeDotState) & + .or. abs(plasticStateResiduum(1:sizeDotState)) < & + rTol_crystalliteState * abs(tempPlasticState(1:sizeDotState))) - plasticState(p)%state(1:mySizePlasticDotState,c) = tempPlasticState(1:mySizePlasticDotState) + plasticState(p)%state(1:sizeDotState,c) = tempPlasticState(1:sizeDotState) do s = 1_pInt, phase_Nsources(p) StateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & sourceState(p)%p(s)%previousDotState (:,c), & sourceState(p)%p(s)%previousDotState2(:,c)) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,s) = & - sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) & - - sourceState(p)%p(s)%subState0(1:mySizeSourceDotState,c) & - - ( sourceState(p)%p(s)%dotState(1:mySizeSourceDotState,c) * stateDamper & - + sourceState(p)%p(s)%previousDotState(1:mySizeSourceDotState,c) & + sizeDotState = sourceState(p)%p(s)%sizeDotState + sourceStateResiduum(1:sizeDotState,s) = & + sourceState(p)%p(s)%state(1:sizeDotState,c) & + - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & + - ( sourceState(p)%p(s)%dotState(1:sizeDotState,c) * stateDamper & + + sourceState(p)%p(s)%previousDotState(1:sizeDotState,c) & * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- - tempSourceState(1:mySizeSourceDotState,s) = & - sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) & - - sourceStateResiduum(1:mySizeSourceDotState,s) ! need to copy to local variable, since we cant flush a pointer in openmp + tempSourceState(1:sizeDotState,s) = & + sourceState(p)%p(s)%state(1:sizeDotState,c) & + - sourceStateResiduum(1:sizeDotState,s) ! need to copy to local variable, since we cant flush a pointer in openmp ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) sourceState(p)%p(s)%dotState(:,c) = & @@ -1684,20 +1683,20 @@ subroutine integrateStateFPI() enddo do s = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sizeDotState = sourceState(p)%p(s)%sizeDotState converged = converged .and. & - all( abs(sourceStateResiduum(1:mySizeSourceDotState,s)) < & - sourceState(p)%p(s)%aTolState(1:mySizeSourceDotState) & - .or. abs(sourceStateResiduum(1:mySizeSourceDotState,s)) < & - rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,s))) + all( abs(sourceStateResiduum(1:sizeDotState,s)) < & + sourceState(p)%p(s)%aTolState(1:sizeDotState) & + .or. abs(sourceStateResiduum(1:sizeDotState,s)) < & + rTol_crystalliteState * abs(tempSourceState(1:sizeDotState,s))) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition do s = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState - sourceState(p)%p(s)%state(1:mySizeSourceDotState,c) = & - tempSourceState(1:mySizeSourceDotState,s) + sizeDotState = sourceState(p)%p(s)%sizeDotState + sourceState(p)%p(s)%state(1:sizeDotState,c) = & + tempSourceState(1:sizeDotState,s) enddo endif enddo; enddo; enddo From 34f3c15552a3639cbe7acbd89f8b001cc123bfef Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 05:47:13 +0100 Subject: [PATCH 317/372] no need for temp variables --- src/crystallite.f90 | 28 ++++++++-------------------- 1 file changed, 8 insertions(+), 20 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 74dfd3731..8efe15040 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1569,11 +1569,9 @@ subroutine integrateStateFPI() real(pReal) :: & stateDamper real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & - plasticStateResiduum, & - tempPlasticState + plasticStateResiduum real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & - sourceStateResiduum, & ! residuum from evolution in micrstructure - tempSourceState + sourceStateResiduum logical :: & converged, & doneWithIntegration @@ -1619,8 +1617,7 @@ subroutine integrateStateFPI() !$OMP DO PRIVATE(sizeDotState, & !$OMP& plasticStateResiduum,sourceStateResiduum, & - !$OMP& stateDamper, & - !$OMP& tempPlasticState,tempSourceState,converged,p,c) + !$OMP& stateDamper, converged,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -1641,11 +1638,10 @@ subroutine integrateStateFPI() * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- - tempPlasticState(1:sizeDotState) = & + plasticState(p)%state(1:sizeDotState,c) = & plasticState(p)%state(1:sizeDotState,c) & - - plasticStateResiduum(1:sizeDotState) ! need to copy to local variable, since we cant flush a pointer in openmp + - plasticStateResiduum(1:sizeDotState) - ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & + plasticState(p)%previousDotState(:,c) & @@ -1654,9 +1650,8 @@ subroutine integrateStateFPI() converged = all( abs(plasticStateResiduum(1:sizeDotState)) < & plasticState(p)%aTolState(1:sizeDotState) & .or. abs(plasticStateResiduum(1:sizeDotState)) < & - rTol_crystalliteState * abs(tempPlasticState(1:sizeDotState))) + rTol_crystalliteState * abs( plasticState(p)%state(1:sizeDotState,c))) - plasticState(p)%state(1:sizeDotState,c) = tempPlasticState(1:sizeDotState) do s = 1_pInt, phase_Nsources(p) StateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & @@ -1671,11 +1666,10 @@ subroutine integrateStateFPI() * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- - tempSourceState(1:sizeDotState,s) = & + sourceState(p)%p(s)%state(1:sizeDotState,c) = & sourceState(p)%p(s)%state(1:sizeDotState,c) & - sourceStateResiduum(1:sizeDotState,s) ! need to copy to local variable, since we cant flush a pointer in openmp - ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) sourceState(p)%p(s)%dotState(:,c) = & sourceState(p)%p(s)%dotState(:,c) * stateDamper & + sourceState(p)%p(s)%previousDotState(:,c) & @@ -1688,16 +1682,10 @@ subroutine integrateStateFPI() all( abs(sourceStateResiduum(1:sizeDotState,s)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState) & .or. abs(sourceStateResiduum(1:sizeDotState,s)) < & - rTol_crystalliteState * abs(tempSourceState(1:sizeDotState,s))) + rTol_crystalliteState * abs(sourceState(p)%p(s)%state(1:sizeDotState,c))) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition - - do s = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceState(p)%p(s)%state(1:sizeDotState,c) = & - tempSourceState(1:sizeDotState,s) - enddo endif enddo; enddo; enddo !$OMP ENDDO From 066c598203a3bdb3f5e84185dd7051712fa17c0c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 10:52:00 +0100 Subject: [PATCH 318/372] wrong dot product in state damper --- src/crystallite.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 8efe15040..ef898bd77 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1744,8 +1744,8 @@ subroutine integrateStateFPI() real(pReal) :: dot_prod12, dot_prod22 - dot_prod12 = dot_product(current - previous, previous - previous2) - dot_prod22 = dot_product(current - previous2, previous - previous2) + dot_prod12 = dot_product(current - previous, previous - previous2) + dot_prod22 = dot_product(previous - previous2, previous - previous2) if (dot_prod22 > 0.0_pReal .and. (dot_prod12 < 0.0_pReal .or. dot_product(current,previous) < 0.0_pReal)) then damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) else From 27b034eb76dfe02a79e2f2e6e519b323ff8ad266 Mon Sep 17 00:00:00 2001 From: Philip Eisenlohr Date: Tue, 29 Jan 2019 12:31:16 -0500 Subject: [PATCH 319/372] fixed bug in recursiveRead that failed to properly {include} in the last line of a file --- src/IO.f90 | 49 +++++++++++++++++++++++++----------------------- src/material.f90 | 6 +++--- 2 files changed, 29 insertions(+), 26 deletions(-) diff --git a/src/IO.f90 b/src/IO.f90 index 1f9ff937c..c8fe26735 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -186,11 +186,10 @@ recursive function IO_recursiveRead(fileName,cnt) result(fileContent) fileUnit, & startPos, endPos, & myTotalLines, & !< # lines read from file without include statements - includedLines, & !< # lines included from other file(s) - missingLines, & !< # lines missing from current file l,i, & myStat - + logical :: warned + if (present(cnt)) then if (cnt>10_pInt) call IO_error(106_pInt,ext_msg=trim(fileName)) endif @@ -207,37 +206,39 @@ recursive function IO_recursiveRead(fileName,cnt) result(fileContent) !-------------------------------------------------------------------------------------------------- ! count lines to allocate string array - myTotalLines = 0_pInt + myTotalLines = 1_pInt do l=1_pInt, len(rawData) - if (rawData(l:l) == new_line('') .or. l==len(rawData)) myTotalLines = myTotalLines+1 ! end of line or end of file without new line + if (rawData(l:l) == new_line('')) myTotalLines = myTotalLines+1 enddo allocate(fileContent(myTotalLines)) !-------------------------------------------------------------------------------------------------- ! split raw data at end of line and handle includes + warned = .false. startPos = 1_pInt - endPos = 0_pInt + l = 1_pInt + do while (l <= myTotalLines) + endPos = merge(startPos + scan(rawData(startPos:),new_line('')) - 2_pInt,len(rawData),l /= myTotalLines) + if (endPos - startPos > 255_pInt) then + line = rawData(startPos:startPos+255_pInt) + if (.not. warned) then + call IO_warning(207_pInt,ext_msg=trim(fileName),el=l) + warned = .true. + endif + else + line = rawData(startPos:endpos) + endif + startPos = endPos + 2_pInt ! jump to next line start - includedLines=0_pInt - l=0_pInt - do while (startPos <= len(rawData)) - l = l + 1_pInt - endPos = endPos + scan(rawData(startPos:),new_line('')) - if(endPos < startPos) endPos = len(rawData) ! end of file without end of line - if(endPos - startPos >256) call IO_error(107_pInt,ext_msg=trim(fileName)) - line = rawData(startPos:endPos-1_pInt) - startPos = endPos + 1_pInt - - recursion: if(scan(trim(line),'{') < scan(trim(line),'}')) then - myTotalLines = myTotalLines - 1_pInt + recursion: if (scan(trim(adjustl(line)),'{') == 1 .and. scan(trim(line),'}') > 2) then includedContent = IO_recursiveRead(trim(line(scan(line,'{')+1_pInt:scan(line,'}')-1_pInt)), & - merge(cnt,1_pInt,present(cnt))) ! to track recursion depth - includedLines = includedLines + size(includedContent) - missingLines = myTotalLines + includedLines - size(fileContent(1:l-1)) -size(includedContent) - fileContent = [ fileContent(1:l-1_pInt), includedContent, [(dummy,i=1,missingLines)] ] ! add content and grow array - l = l - 1_pInt + size(includedContent) + merge(cnt,1_pInt,present(cnt))) ! to track recursion depth + fileContent = [ fileContent(1:l-1_pInt), includedContent, [(dummy,i=1,myTotalLines-l)] ] ! add content and grow array + myTotalLines = myTotalLines - 1_pInt + size(includedContent) + l = l - 1_pInt + size(includedContent) else recursion fileContent(l) = line + l = l + 1_pInt endif recursion enddo @@ -1498,6 +1499,8 @@ subroutine IO_warning(warning_ID,el,ip,g,ext_msg) msg = 'invalid character in string chunk' case (203_pInt) msg = 'interpretation of string chunk failed' + case (207_pInt) + msg = 'line truncated' case (600_pInt) msg = 'crystallite responds elastically' case (601_pInt) diff --git a/src/material.f90 b/src/material.f90 index d12321235..3ae6c16a4 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -327,19 +327,19 @@ subroutine material_init() #include "compilation_info.f90" call material_parsePhase() - if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Phase parsed'; flush(6) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Phase parsed'; flush(6) call material_parseMicrostructure() if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Microstructure parsed'; flush(6) call material_parseCrystallite() - if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Crystallite parsed'; flush(6) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Crystallite parsed'; flush(6) call material_parseHomogenization() if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Homogenization parsed'; flush(6) call material_parseTexture() - if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Texture parsed'; flush(6) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Texture parsed'; flush(6) allocate(plasticState (size(config_phase))) allocate(sourceState (size(config_phase))) From 0c21da2605b55bf0df36d7166977094fcaabd3a2 Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 29 Jan 2019 19:25:42 +0100 Subject: [PATCH 320/372] [skip ci] updated version information after successful test of v2.0.2-1614-g8764c615 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 31608bd97..82ddb5e1a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1608-gcd3cbf47 +v2.0.2-1614-g8764c615 From c017b6eea3af3fe9c8dce70904b30e63a6db80bf Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 29 Jan 2019 22:02:19 +0100 Subject: [PATCH 321/372] [skip ci] updated version information after successful test of v2.0.2-1615-g27b034eb --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 31608bd97..bf866d316 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1608-gcd3cbf47 +v2.0.2-1615-g27b034eb From 38d8e429fff2c4bdab56291ee209d853fa8a1c6b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 08:29:19 +0100 Subject: [PATCH 322/372] layout adjustments --- src/crystallite.f90 | 90 ++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 50 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index ef898bd77..74eef259e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1586,24 +1586,25 @@ subroutine integrateStateFPI() NiterationState = NiterationState + 1_pInt ! store previousDotState and previousDotState2 + !$OMP PARALLEL DO PRIVATE(p,c) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - plasticState(p)%previousDotState2(:,c) = merge(plasticState(p)%previousDotState(:,c),& - 0.0_pReal,& - NiterationState > 1_pInt) - plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) - do s = 1_pInt, phase_Nsources(p) - sourceState(p)%p(s)%previousDotState2(:,c) = merge(sourceState(p)%p(s)%previousDotState(:,c),& - 0.0_pReal, & - NiterationState > 1_pInt) - sourceState(p)%p(s)%previousDotState (:,c) = sourceState(p)%p(s)%dotState(:,c) - enddo - endif + plasticState(p)%previousDotState2(:,c) = merge(plasticState(p)%previousDotState(:,c),& + 0.0_pReal,& + NiterationState > 1_pInt) + plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) + do s = 1_pInt, phase_Nsources(p) + sourceState(p)%p(s)%previousDotState2(:,c) = merge(sourceState(p)%p(s)%previousDotState(:,c),& + 0.0_pReal, & + NiterationState > 1_pInt) + sourceState(p)%p(s)%previousDotState (:,c) = sourceState(p)%p(s)%dotState(:,c) + enddo + endif enddo enddo enddo @@ -1612,40 +1613,33 @@ subroutine integrateStateFPI() call update_dependentState call update_stress(1.0_pReal) call update_dotState(1.0_pReal) -!$OMP PARALLEL - ! --- UPDATE STATE --- - + + !$OMP PARALLEL !$OMP DO PRIVATE(sizeDotState, & !$OMP& plasticStateResiduum,sourceStateResiduum, & !$OMP& stateDamper, converged,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) StateDamper = damper(plasticState(p)%dotState (:,c), & plasticState(p)%previousDotState (:,c), & plasticState(p)%previousDotState2(:,c)) + sizeDotState = plasticState(p)%sizeDotState - sizeDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:sizeDotState) = & - plasticState(p)%state(1:sizeDotState,c) & - - plasticState(p)%subState0(1:sizeDotState,c) & - - ( plasticState(p)%dotState(1:sizeDotState,c) * stateDamper & - + plasticState(p)%previousDotState(1:sizeDotState,c) & - * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) + plasticStateResiduum(1:sizeDotState) = plasticState(p)%state (1:sizeDotState,c) & + - plasticState(p)%subState0(1:sizeDotState,c) & + - ( plasticState(p)%dotState (:,c) * stateDamper & + + plasticState(p)%previousDotState(:,c) * (1.0_pReal-stateDamper) & + ) * crystallite_subdt(g,i,e) - ! --- correct state with residuum --- - plasticState(p)%state(1:sizeDotState,c) = & - plasticState(p)%state(1:sizeDotState,c) & - - plasticStateResiduum(1:sizeDotState) + plasticState(p)%state(1:sizeDotState,c) = plasticState(p)%state(1:sizeDotState,c) & + - plasticStateResiduum(1:sizeDotState) - - plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & - + plasticState(p)%previousDotState(:,c) & - * (1.0_pReal - stateDamper) + plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & + + plasticState(p)%previousDotState(:,c) * (1.0_pReal - stateDamper) converged = all( abs(plasticStateResiduum(1:sizeDotState)) < & plasticState(p)%aTolState(1:sizeDotState) & @@ -1653,17 +1647,16 @@ subroutine integrateStateFPI() rTol_crystalliteState * abs( plasticState(p)%state(1:sizeDotState,c))) - do s = 1_pInt, phase_Nsources(p) - StateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & + do s = 1_pInt, phase_Nsources(p) + stateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & sourceState(p)%p(s)%previousDotState (:,c), & sourceState(p)%p(s)%previousDotState2(:,c)) - sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s) = & - sourceState(p)%p(s)%state(1:sizeDotState,c) & - - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & - - ( sourceState(p)%p(s)%dotState(1:sizeDotState,c) * stateDamper & - + sourceState(p)%p(s)%previousDotState(1:sizeDotState,c) & - * (1.0_pReal - stateDamper)) * crystallite_subdt(g,i,e) + sizeDotState = sourceState(p)%p(s)%sizeDotState + sourceStateResiduum(1:sizeDotState,s) = sourceState(p)%p(s)%state (1:sizeDotState,c) & + - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & + - ( sourceState(p)%p(s)%dotState (:,c) * stateDamper & + + sourceState(p)%p(s)%previousDotState(:,c) * (1.0_pReal - stateDamper) & + ) * crystallite_subdt(g,i,e) ! --- correct state with residuum --- sourceState(p)%p(s)%state(1:sizeDotState,c) = & @@ -1674,10 +1667,7 @@ subroutine integrateStateFPI() sourceState(p)%p(s)%dotState(:,c) * stateDamper & + sourceState(p)%p(s)%previousDotState(:,c) & * (1.0_pReal - stateDamper) - enddo - do s = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(s)%sizeDotState converged = converged .and. & all( abs(sourceStateResiduum(1:sizeDotState,s)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState) & @@ -1921,7 +1911,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) enddo - if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definitionem + if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition endif enddo; enddo; enddo !$OMP END PARALLEL DO From 73f39136c48b5b33f7f515b545dd36ac54c26d32 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 22:19:38 +0100 Subject: [PATCH 323/372] taking over from old branch --- src/crystallite.f90 | 37 ++++++++++++++----------------------- 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 74eef259e..b720c4101 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1551,7 +1551,6 @@ subroutine integrateStateFPI() homogenization_Ngrains use constitutive, only: & constitutive_collectDotState, & - constitutive_microstructure, & constitutive_plasticity_maxSizeDotState, & constitutive_source_maxSizeDotState @@ -1569,9 +1568,9 @@ subroutine integrateStateFPI() real(pReal) :: & stateDamper real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & - plasticStateResiduum + residuum_plastic ! residuum for plastic state real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & - sourceStateResiduum + residuum_source ! residuum for source state logical :: & converged, & doneWithIntegration @@ -1616,7 +1615,7 @@ subroutine integrateStateFPI() !$OMP PARALLEL !$OMP DO PRIVATE(sizeDotState, & - !$OMP& plasticStateResiduum,sourceStateResiduum, & + !$OMP& residuum_plastic,residuum_source, & !$OMP& stateDamper, converged,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) @@ -1629,21 +1628,20 @@ subroutine integrateStateFPI() plasticState(p)%previousDotState2(:,c)) sizeDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:sizeDotState) = plasticState(p)%state (1:sizeDotState,c) & + residuum_plastic(1:SizeDotState) = plasticState(p)%state (1:sizeDotState,c) & - plasticState(p)%subState0(1:sizeDotState,c) & - ( plasticState(p)%dotState (:,c) * stateDamper & + plasticState(p)%previousDotState(:,c) * (1.0_pReal-stateDamper) & ) * crystallite_subdt(g,i,e) plasticState(p)%state(1:sizeDotState,c) = plasticState(p)%state(1:sizeDotState,c) & - - plasticStateResiduum(1:sizeDotState) - + - residuum_plastic(1:sizeDotState) plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & + plasticState(p)%previousDotState(:,c) * (1.0_pReal - stateDamper) - converged = all( abs(plasticStateResiduum(1:sizeDotState)) < & + converged = all( abs(residuum_plastic(1:sizeDotState)) < & plasticState(p)%aTolState(1:sizeDotState) & - .or. abs(plasticStateResiduum(1:sizeDotState)) < & + .or. abs(residuum_plastic(1:sizeDotState)) < & rTol_crystalliteState * abs( plasticState(p)%state(1:sizeDotState,c))) @@ -1652,26 +1650,21 @@ subroutine integrateStateFPI() sourceState(p)%p(s)%previousDotState (:,c), & sourceState(p)%p(s)%previousDotState2(:,c)) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s) = sourceState(p)%p(s)%state (1:sizeDotState,c) & + residuum_source(1:sizeDotState,s) = sourceState(p)%p(s)%state (1:sizeDotState,c) & - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & - ( sourceState(p)%p(s)%dotState (:,c) * stateDamper & + sourceState(p)%p(s)%previousDotState(:,c) * (1.0_pReal - stateDamper) & ) * crystallite_subdt(g,i,e) - ! --- correct state with residuum --- - sourceState(p)%p(s)%state(1:sizeDotState,c) = & - sourceState(p)%p(s)%state(1:sizeDotState,c) & - - sourceStateResiduum(1:sizeDotState,s) ! need to copy to local variable, since we cant flush a pointer in openmp - - sourceState(p)%p(s)%dotState(:,c) = & - sourceState(p)%p(s)%dotState(:,c) * stateDamper & - + sourceState(p)%p(s)%previousDotState(:,c) & - * (1.0_pReal - stateDamper) + sourceState(p)%p(s)%state(1:sizeDotState,c) = sourceState(p)%p(s)%state(1:sizeDotState,c) & + - residuum_source(1:sizeDotState,s) + sourceState(p)%p(s)%dotState(:,c) = sourceState(p)%p(s)%dotState(:,c) * stateDamper & + + sourceState(p)%p(s)%previousDotState(:,c)* (1.0_pReal - stateDamper) converged = converged .and. & - all( abs(sourceStateResiduum(1:sizeDotState,s)) < & + all( abs(residuum_source(1:sizeDotState,s)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState) & - .or. abs(sourceStateResiduum(1:sizeDotState,s)) < & + .or. abs(residuum_source(1:sizeDotState,s)) < & rTol_crystalliteState * abs(sourceState(p)%p(s)%state(1:sizeDotState,c))) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition @@ -1771,8 +1764,6 @@ end subroutine integrateStateEuler !> @brief integrate stress, state with 1st order Euler method with adaptive step size !-------------------------------------------------------------------------------------------------- subroutine integrateStateAdaptiveEuler() - use, intrinsic :: & - IEEE_arithmetic use numerics, only: & rTol_crystalliteState use mesh, only: & From b4afc303be3b2cdbd98bbc629d413cd96f3c17c3 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 22:29:36 +0100 Subject: [PATCH 324/372] clearer logic --- src/crystallite.f90 | 96 ++++++++++++++++++++++----------------------- 1 file changed, 46 insertions(+), 50 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b720c4101..be14f801a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1566,13 +1566,12 @@ subroutine integrateStateFPI() s, & sizeDotState real(pReal) :: & - stateDamper + zeta real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & residuum_plastic ! residuum for plastic state - real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & + real(pReal), dimension(constitutive_source_maxSizeDotState) :: & residuum_source ! residuum for source state logical :: & - converged, & doneWithIntegration ! --+>> PREGUESS FOR STATE <<+-- @@ -1614,65 +1613,59 @@ subroutine integrateStateFPI() call update_dotState(1.0_pReal) !$OMP PARALLEL - !$OMP DO PRIVATE(sizeDotState, & - !$OMP& residuum_plastic,residuum_source, & - !$OMP& stateDamper, converged,p,c) + !$OMP DO PRIVATE(sizeDotState,residuum_plastic,residuum_source,zeta,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - StateDamper = damper(plasticState(p)%dotState (:,c), & - plasticState(p)%previousDotState (:,c), & - plasticState(p)%previousDotState2(:,c)) + zeta = damper(plasticState(p)%dotState (:,c), & + plasticState(p)%previousDotState (:,c), & + plasticState(p)%previousDotState2(:,c)) sizeDotState = plasticState(p)%sizeDotState residuum_plastic(1:SizeDotState) = plasticState(p)%state (1:sizeDotState,c) & - plasticState(p)%subState0(1:sizeDotState,c) & - - ( plasticState(p)%dotState (:,c) * stateDamper & - + plasticState(p)%previousDotState(:,c) * (1.0_pReal-stateDamper) & + - ( plasticState(p)%dotState (:,c) * zeta & + + plasticState(p)%previousDotState(:,c) * (1.0_pReal-zeta) & ) * crystallite_subdt(g,i,e) plasticState(p)%state(1:sizeDotState,c) = plasticState(p)%state(1:sizeDotState,c) & - residuum_plastic(1:sizeDotState) - plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * stateDamper & - + plasticState(p)%previousDotState(:,c) * (1.0_pReal - stateDamper) - - converged = all( abs(residuum_plastic(1:sizeDotState)) < & - plasticState(p)%aTolState(1:sizeDotState) & - .or. abs(residuum_plastic(1:sizeDotState)) < & - rTol_crystalliteState * abs( plasticState(p)%state(1:sizeDotState,c))) + plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * zeta & + + plasticState(p)%previousDotState(:,c) * (1.0_pReal - zeta) + + crystallite_converged(g,i,e) = all(abs(residuum_plastic(1:sizeDotState)) & + < min(plasticState(p)%aTolState(1:sizeDotState), & + abs(plasticState(p)%state(1:sizeDotState,c)*rTol_crystalliteState))) do s = 1_pInt, phase_Nsources(p) - stateDamper = damper(sourceState(p)%p(s)%dotState (:,c), & - sourceState(p)%p(s)%previousDotState (:,c), & - sourceState(p)%p(s)%previousDotState2(:,c)) + zeta = damper(sourceState(p)%p(s)%dotState (:,c), & + sourceState(p)%p(s)%previousDotState (:,c), & + sourceState(p)%p(s)%previousDotState2(:,c)) sizeDotState = sourceState(p)%p(s)%sizeDotState - residuum_source(1:sizeDotState,s) = sourceState(p)%p(s)%state (1:sizeDotState,c) & - - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & - - ( sourceState(p)%p(s)%dotState (:,c) * stateDamper & - + sourceState(p)%p(s)%previousDotState(:,c) * (1.0_pReal - stateDamper) & - ) * crystallite_subdt(g,i,e) + + residuum_source(1:sizeDotState) = sourceState(p)%p(s)%state (1:sizeDotState,c) & + - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & + - ( sourceState(p)%p(s)%dotState (:,c) * zeta & + + sourceState(p)%p(s)%previousDotState(:,c) * (1.0_pReal - zeta) & + ) * crystallite_subdt(g,i,e) - sourceState(p)%p(s)%state(1:sizeDotState,c) = sourceState(p)%p(s)%state(1:sizeDotState,c) & - - residuum_source(1:sizeDotState,s) - sourceState(p)%p(s)%dotState(:,c) = sourceState(p)%p(s)%dotState(:,c) * stateDamper & - + sourceState(p)%p(s)%previousDotState(:,c)* (1.0_pReal - stateDamper) + sourceState(p)%p(s)%state(1:sizeDotState,c) = sourceState(p)%p(s)%state(1:sizeDotState,c) & + - residuum_source(1:sizeDotState) + sourceState(p)%p(s)%dotState(:,c) = sourceState(p)%p(s)%dotState(:,c) * zeta & + + sourceState(p)%p(s)%previousDotState(:,c)* (1.0_pReal - zeta) - converged = converged .and. & - all( abs(residuum_source(1:sizeDotState,s)) < & - sourceState(p)%p(s)%aTolState(1:sizeDotState) & - .or. abs(residuum_source(1:sizeDotState,s)) < & - rTol_crystalliteState * abs(sourceState(p)%p(s)%state(1:sizeDotState,c))) - enddo - if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition - - endif - enddo; enddo; enddo + crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & + all(abs(residuum_source(1:sizeDotState)) & + < min(sourceState(p)%p(s)%aTolState(1:sizeDotState), & + abs(sourceState(p)%p(s)%state(1:sizeDotState,c)*rTol_crystalliteState))) + enddo + endif + enddo; enddo; enddo !$OMP ENDDO - ! --- STATE JUMP --- !$OMP DO do e = FEsolving_execElem(1),FEsolving_execElem(2) @@ -1870,6 +1863,17 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & plasticStateResiduum(1:mySizePlasticDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + + converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) + + forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & + relPlasticStateResiduum(s,g,i,e) = & + plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) + + do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & @@ -1878,10 +1882,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state enddo - ! --- relative residui --- - forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & - relPlasticStateResiduum(s,g,i,e) = & - plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) + do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & @@ -1889,11 +1890,6 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) enddo - ! --- converged ? --- - converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState converged = converged .and. & From 0be05b3ee1c4a894b2e442ff3156945bb3a5efe5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 22:46:21 +0100 Subject: [PATCH 325/372] one variable is enough --- src/crystallite.f90 | 63 ++++++++++++++++++++++----------------------- 1 file changed, 31 insertions(+), 32 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index be14f801a..100bd1aa4 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1785,8 +1785,7 @@ subroutine integrateStateAdaptiveEuler() p, & c, & mySource, & - mySizePlasticDotState, & ! size of dot states - mySizeSourceDotState + sizeDotState real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & plasticStateResiduum, & ! residuum from evolution in micrstructure @@ -1810,31 +1809,31 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & ! contribution to state and relative residui and from Euler integration call update_dotState(1.0_pReal) - !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + sizeDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:sizeDotState,g,i,e) = & - 0.5_pReal & - * plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + * plasticState(p)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - plasticState(p)%state (1:mySizePlasticDotState,c) = & - plasticState(p)%state (1:mySizePlasticDotState,c) & - + plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + plasticState(p)%state (1:sizeDotState,c) = & + plasticState(p)%state (1:sizeDotState,c) & + + plasticState(p)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + sizeDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:sizeDotState,mySource,g,i,e) = & - 0.5_pReal & - * sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + * sourceState(p)%p(mySource)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & - sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) & - + sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + sourceState(p)%p(mySource)%state (1:sizeDotState,c) = & + sourceState(p)%p(mySource)%state (1:sizeDotState,c) & + + sourceState(p)%p(mySource)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) enddo endif @@ -1850,7 +1849,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) + !$OMP PARALLEL DO PRIVATE(sizeDotState,converged,p,c,s) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -1858,45 +1857,45 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & p = phaseAt(g,i,e); c = phasememberAt(g,i,e) ! --- contribution of heun step to absolute residui --- - mySizePlasticDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) & + sizeDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:sizeDotState,g,i,e) = & + plasticStateResiduum(1:sizeDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + converged = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) + abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & + plasticState(p)%aTolState(1:sizeDotState)) - forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & + forall (s = 1_pInt:sizeDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & relPlasticStateResiduum(s,g,i,e) = & plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) & + sizeDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:sizeDotState,mySource,g,i,e) = & + sourceStateResiduum(1:sizeDotState,mySource,g,i,e) & + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state enddo do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & + sizeDotState = sourceState(p)%p(mySource)%sizeDotState + forall (s = 1_pInt:sizeDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & relSourceStateResiduum(s,mySource,g,i,e) = & sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) enddo do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sizeDotState = sourceState(p)%p(mySource)%sizeDotState converged = converged .and. & - all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + all(abs(relSourceStateResiduum(1:sizeDotState,mySource,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + abs(sourceStateResiduum(1:sizeDotState,mySource,g,i,e)) < & + sourceState(p)%p(mySource)%aTolState(1:sizeDotState)) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition endif From 1408d66c0caec280768039732cb09ad53b579475 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 23:02:59 +0100 Subject: [PATCH 326/372] s is used for source --- src/crystallite.f90 | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 100bd1aa4..b416573de 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1781,7 +1781,7 @@ subroutine integrateStateAdaptiveEuler() e, & ! element index in element loop i, & ! integration point index in ip loop g, & ! grain index in grain loop - s, & ! state index + u, & ! state index p, & c, & mySource, & @@ -1849,7 +1849,7 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL DO PRIVATE(sizeDotState,converged,p,c,s) + !$OMP PARALLEL DO PRIVATE(sizeDotState,converged,p,c,u) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -1868,9 +1868,9 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & plasticState(p)%aTolState(1:sizeDotState)) - forall (s = 1_pInt:sizeDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & - relPlasticStateResiduum(s,g,i,e) = & - plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) + forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%dotState(u,c)) > 0.0_pReal) & + relPlasticStateResiduum(u,g,i,e) = & + plasticStateResiduum(u,g,i,e) / plasticState(p)%dotState(u,c) do mySource = 1_pInt, phase_Nsources(p) @@ -1879,17 +1879,11 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & sourceStateResiduum(1:sizeDotState,mySource,g,i,e) & + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - enddo + forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(mySource)%dotState(u,c)) > 0.0_pReal) & + relSourceStateResiduum(u,mySource,g,i,e) = & + sourceStateResiduum(u,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(u,c) - do mySource = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(mySource)%sizeDotState - forall (s = 1_pInt:sizeDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & - relSourceStateResiduum(s,mySource,g,i,e) = & - sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) - enddo - - do mySource = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(mySource)%sizeDotState converged = converged .and. & all(abs(relSourceStateResiduum(1:sizeDotState,mySource,g,i,e)) < & From eade54a68f49c31e274577292970271efef2d915 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 23:04:50 +0100 Subject: [PATCH 327/372] consistent variable names --- src/crystallite.f90 | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b416573de..054bb9d22 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1784,7 +1784,7 @@ subroutine integrateStateAdaptiveEuler() u, & ! state index p, & c, & - mySource, & + s, & sizeDotState real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & @@ -1825,15 +1825,15 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & plasticState(p)%state (1:sizeDotState,c) & + plasticState(p)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) - do mySource = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:sizeDotState,mySource,g,i,e) = & + do s = 1_pInt, phase_Nsources(p) + sizeDotState = sourceState(p)%p(s)%sizeDotState + sourceStateResiduum(1:sizeDotState,s,g,i,e) = & - 0.5_pReal & - * sourceState(p)%p(mySource)%dotstate(1:sizeDotState,c) & + * sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - sourceState(p)%p(mySource)%state (1:sizeDotState,c) = & - sourceState(p)%p(mySource)%state (1:sizeDotState,c) & - + sourceState(p)%p(mySource)%dotstate(1:sizeDotState,c) & + sourceState(p)%p(s)%state (1:sizeDotState,c) = & + sourceState(p)%p(s)%state (1:sizeDotState,c) & + + sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & * crystallite_subdt(g,i,e) enddo endif @@ -1873,23 +1873,23 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & plasticStateResiduum(u,g,i,e) / plasticState(p)%dotState(u,c) - do mySource = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(mySource)%sizeDotState - sourceStateResiduum(1:sizeDotState,mySource,g,i,e) = & - sourceStateResiduum(1:sizeDotState,mySource,g,i,e) & - + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & + do s = 1_pInt, phase_Nsources(p) + sizeDotState = sourceState(p)%p(s)%sizeDotState + sourceStateResiduum(1:sizeDotState,s,g,i,e) = & + sourceStateResiduum(1:sizeDotState,s,g,i,e) & + + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) & * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(mySource)%dotState(u,c)) > 0.0_pReal) & - relSourceStateResiduum(u,mySource,g,i,e) = & - sourceStateResiduum(u,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(u,c) + forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%dotState(u,c)) > 0.0_pReal) & + relSourceStateResiduum(u,s,g,i,e) = & + sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%dotState(u,c) - sizeDotState = sourceState(p)%p(mySource)%sizeDotState + sizeDotState = sourceState(p)%p(s)%sizeDotState converged = converged .and. & - all(abs(relSourceStateResiduum(1:sizeDotState,mySource,g,i,e)) < & + all(abs(relSourceStateResiduum(1:sizeDotState,s,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:sizeDotState,mySource,g,i,e)) < & - sourceState(p)%p(mySource)%aTolState(1:sizeDotState)) + abs(sourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition endif From bdd193fbd73eb9a1e2214684b90d4425edd94519 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 23:31:26 +0100 Subject: [PATCH 328/372] now readable (kind of) --- src/crystallite.f90 | 105 ++++++++++++++++++-------------------------- 1 file changed, 43 insertions(+), 62 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 054bb9d22..2e68ae756 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1619,12 +1619,12 @@ subroutine integrateStateFPI() do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + sizeDotState = plasticState(p)%sizeDotState zeta = damper(plasticState(p)%dotState (:,c), & plasticState(p)%previousDotState (:,c), & plasticState(p)%previousDotState2(:,c)) - sizeDotState = plasticState(p)%sizeDotState - + residuum_plastic(1:SizeDotState) = plasticState(p)%state (1:sizeDotState,c) & - plasticState(p)%subState0(1:sizeDotState,c) & - ( plasticState(p)%dotState (:,c) * zeta & @@ -1642,11 +1642,12 @@ subroutine integrateStateFPI() do s = 1_pInt, phase_Nsources(p) + sizeDotState = sourceState(p)%p(s)%sizeDotState + zeta = damper(sourceState(p)%p(s)%dotState (:,c), & sourceState(p)%p(s)%previousDotState (:,c), & sourceState(p)%p(s)%previousDotState2(:,c)) - sizeDotState = sourceState(p)%p(s)%sizeDotState - + residuum_source(1:sizeDotState) = sourceState(p)%p(s)%state (1:sizeDotState,c) & - sourceState(p)%p(s)%subState0(1:sizeDotState,c) & - ( sourceState(p)%p(s)%dotState (:,c) * zeta & @@ -1771,8 +1772,6 @@ subroutine integrateStateAdaptiveEuler() phase_Nsources, & homogenization_maxNgrains use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure, & constitutive_plasticity_maxSizeDotState, & constitutive_source_maxSizeDotState @@ -1786,6 +1785,8 @@ subroutine integrateStateAdaptiveEuler() c, & s, & sizeDotState + + ! ToDo: MD: once all constitutives use allocate state, attach these arrays to the state in case of adaptive Euler real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & plasticStateResiduum, & ! residuum from evolution in micrstructure @@ -1796,45 +1797,29 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & sourceStateResiduum, & ! residuum from evolution in micrstructure relSourceStateResiduum ! relative residuum from evolution in microstructure - logical :: & - converged - - - plasticStateResiduum = 0.0_pReal - relPlasticStateResiduum = 0.0_pReal - sourceStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal - !-------------------------------------------------------------------------------------------------- ! contribution to state and relative residui and from Euler integration call update_dotState(1.0_pReal) !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then - p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:sizeDotState,g,i,e) = & - - 0.5_pReal & - * plasticState(p)%dotstate(1:sizeDotState,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - plasticState(p)%state (1:sizeDotState,c) = & - plasticState(p)%state (1:sizeDotState,c) & - + plasticState(p)%dotstate(1:sizeDotState,c) & - * crystallite_subdt(g,i,e) + + plasticStateResiduum(1:sizeDotState,g,i,e) = plasticState(p)%dotstate(1:sizeDotState,c) & + * (- 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) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s,g,i,e) = & - - 0.5_pReal & - * sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - sourceState(p)%p(s)%state (1:sizeDotState,c) = & - sourceState(p)%p(s)%state (1:sizeDotState,c) & - + sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & - * crystallite_subdt(g,i,e) + + sourceStateResiduum(1:sizeDotState,s,g,i,e) = sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & + * (- 0.5_pReal * crystallite_subdt(g,i,e)) + sourceState(p)%p(s)%state(1:sizeDotState,c) = sourceState(p)%p(s)%state(1:sizeDotState,c) & + + sourceState(p)%p(s)%dotstate(1:sizeDotState,c) * crystallite_subdt(g,i,e) !ToDo: state, partitioned state? enddo endif enddo; enddo; enddo @@ -1845,55 +1830,51 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & call update_stress(1.0_pReal) call update_dotState(1.0_pReal) - relPlasticStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal + relPlasticStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL DO PRIVATE(sizeDotState,converged,p,c,u) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c,u) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + sizeDotState = plasticState(p)%sizeDotState ! --- contribution of heun step to absolute residui --- - sizeDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:sizeDotState,g,i,e) = & - plasticStateResiduum(1:sizeDotState,g,i,e) & - + 0.5_pReal * plasticState(p)%dotState(:,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + + plasticStateResiduum(1:sizeDotState,g,i,e) = plasticStateResiduum(1:sizeDotState,g,i,e) & + + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - converged = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & + crystallite_converged(g,i,e) = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & rTol_crystalliteState .or. & abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & plasticState(p)%aTolState(1:sizeDotState)) forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%dotState(u,c)) > 0.0_pReal) & - relPlasticStateResiduum(u,g,i,e) = & - plasticStateResiduum(u,g,i,e) / plasticState(p)%dotState(u,c) + relPlasticStateResiduum(u,g,i,e) = plasticStateResiduum(u,g,i,e) & + / plasticState(p)%dotState(u,c) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s,g,i,e) = & - sourceStateResiduum(1:sizeDotState,s,g,i,e) & - + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) & - * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state - + + sourceStateResiduum(1:sizeDotState,s,g,i,e) = sourceStateResiduum(1:sizeDotState,s,g,i,e) & + + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) + forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%dotState(u,c)) > 0.0_pReal) & - relSourceStateResiduum(u,s,g,i,e) = & - sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%dotState(u,c) + relSourceStateResiduum(u,s,g,i,e) = sourceStateResiduum(u,s,g,i,e) & + / sourceState(p)%p(s)%dotState(u,c) - sizeDotState = sourceState(p)%p(s)%sizeDotState - converged = converged .and. & + crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & all(abs(relSourceStateResiduum(1:sizeDotState,s,g,i,e)) < & rTol_crystalliteState .or. & abs(sourceStateResiduum(1:sizeDotState,s,g,i,e)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo - if (converged) crystallite_converged(g,i,e) = .true. ! ... converged per definition endif - enddo; enddo; enddo + enddo; enddo; enddo !$OMP END PARALLEL DO if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck From 6a3dac1df2ba3fe6fd0cd1bb457cdcc3b175ee72 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 29 Jan 2019 23:45:41 +0100 Subject: [PATCH 329/372] still improving readability --- src/crystallite.f90 | 72 ++++++++++++++++++++++++--------------------- 1 file changed, 38 insertions(+), 34 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 2e68ae756..7fb3aefe6 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1758,6 +1758,8 @@ end subroutine integrateStateEuler !> @brief integrate stress, state with 1st order Euler method with adaptive step size !-------------------------------------------------------------------------------------------------- subroutine integrateStateAdaptiveEuler() + use prec, only: & + dNeq0 use numerics, only: & rTol_crystalliteState use mesh, only: & @@ -1780,22 +1782,23 @@ subroutine integrateStateAdaptiveEuler() e, & ! element index in element loop i, & ! integration point index in ip loop g, & ! grain index in grain loop - u, & ! state index p, & c, & s, & sizeDotState - ! ToDo: MD: once all constitutives use allocate state, attach these arrays to the state in case of adaptive Euler + ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler + ! ToDo: MD: rel residuu don't have to be pointwise + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - plasticStateResiduum, & ! residuum from evolution in micrstructure - relPlasticStateResiduum ! relative residuum from evolution in microstructure + residuum_plastic, & + residuum_plastic_rel real(pReal), dimension(constitutive_source_maxSizeDotState,& maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - sourceStateResiduum, & ! residuum from evolution in micrstructure - relSourceStateResiduum ! relative residuum from evolution in microstructure + residuum_source_rel, & + residuum_source !-------------------------------------------------------------------------------------------------- ! contribution to state and relative residui and from Euler integration @@ -1809,15 +1812,15 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState - plasticStateResiduum(1:sizeDotState,g,i,e) = plasticState(p)%dotstate(1:sizeDotState,c) & - * (- 0.5_pReal * crystallite_subdt(g,i,e)) + residuum_plastic(1:sizeDotState,g,i,e) = plasticState(p)%dotstate(1:sizeDotState,c) & + * (- 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) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s,g,i,e) = sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & - * (- 0.5_pReal * crystallite_subdt(g,i,e)) + residuum_source(1:sizeDotState,s,g,i,e) = sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & + * (- 0.5_pReal * crystallite_subdt(g,i,e)) sourceState(p)%p(s)%state(1:sizeDotState,c) = sourceState(p)%p(s)%state(1:sizeDotState,c) & + sourceState(p)%p(s)%dotstate(1:sizeDotState,c) * crystallite_subdt(g,i,e) !ToDo: state, partitioned state? enddo @@ -1829,12 +1832,8 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & call update_dependentState call update_stress(1.0_pReal) call update_dotState(1.0_pReal) - - relPlasticStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal - - !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c,u) + !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -1844,33 +1843,38 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & ! --- contribution of heun step to absolute residui --- - plasticStateResiduum(1:sizeDotState,g,i,e) = plasticStateResiduum(1:sizeDotState,g,i,e) & - + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - - crystallite_converged(g,i,e) = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & - plasticState(p)%aTolState(1:sizeDotState)) - - forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%dotState(u,c)) > 0.0_pReal) & - relPlasticStateResiduum(u,g,i,e) = plasticStateResiduum(u,g,i,e) & - / plasticState(p)%dotState(u,c) + residuum_plastic(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - + where(dNeq0(plasticState(p)%dotState(1:sizeDotState,c))) + residuum_plastic_rel(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + / plasticState(p)%dotState(1:sizeDotState,c) + else where + residuum_plastic_rel(1:sizeDotState,g,i,e) = 0.0_pReal + end where + + crystallite_converged(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(residuum_plastic(1:sizeDotState,g,i,e)) < & + plasticState(p)%aTolState(1:sizeDotState)) + do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceStateResiduum(1:sizeDotState,s,g,i,e) = sourceStateResiduum(1:sizeDotState,s,g,i,e) & - + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) + residuum_source(1:sizeDotState,s,g,i,e) = residuum_source(1:sizeDotState,s,g,i,e) & + + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) - forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%dotState(u,c)) > 0.0_pReal) & - relSourceStateResiduum(u,s,g,i,e) = sourceStateResiduum(u,s,g,i,e) & - / sourceState(p)%p(s)%dotState(u,c) + where(dNeq0(sourceState(p)%p(s)%dotState(1:sizeDotState,c))) + residuum_source_rel(1:sizeDotState,s,g,i,e) = residuum_source(1:sizeDotState,s,g,i,e) & + / sourceState(p)%p(s)%dotState(1:sizeDotState,c) + else where + residuum_source_rel(1:SizeDotState,s,g,i,e) = 0.0_pReal + end where crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & - all(abs(relSourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + all(abs(residuum_source_rel(1:sizeDotState,s,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + abs(residuum_source(1:sizeDotState,s,g,i,e)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif From 1a66f976b7e5d7f2edf6493562e92e10ea8f10d1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 00:01:40 +0100 Subject: [PATCH 330/372] common variable name --- src/crystallite.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 7fb3aefe6..b47f3334f 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1919,7 +1919,7 @@ subroutine integrateStateRK4() p, & ! phase loop c, & n, & - mySource + s integer(pInt), dimension(2) :: eIter ! bounds for element iteration integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration gIter ! bounds for grain iteration @@ -1938,8 +1938,8 @@ subroutine integrateStateRK4() if (.not. singleRun) then do p = 1_pInt, material_Nphase plasticState(p)%RK4dotState = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RK4dotState = 0.0_pReal + do s = 1_pInt, phase_Nsources(p) + sourceState(p)%p(s)%RK4dotState = 0.0_pReal enddo enddo else @@ -1947,8 +1947,8 @@ subroutine integrateStateRK4() i = iIter(1,e) do g = gIter(1,e), gIter(2,e) plasticState(phaseAt(g,i,e))%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) - sourceState(phaseAt(g,i,e))%p(mySource)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal + do s = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + sourceState(phaseAt(g,i,e))%p(s)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal enddo enddo endif @@ -1967,13 +1967,13 @@ subroutine integrateStateRK4() do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - c = phasememberAt(g,i,e) + p = phaseAt(g,i,e); c = phasememberAt(g,i,e) + plasticState(p)%RK4dotState(:,c) = plasticState(p)%RK4dotState(:,c) & + weight(n)*plasticState(p)%dotState(:,c) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RK4dotState(:,c) = sourceState(p)%p(mySource)%RK4dotState(:,c) & - + weight(n)*sourceState(p)%p(mySource)%dotState(:,c) + do s = 1_pInt, phase_Nsources(p) + sourceState(p)%p(s)%RK4dotState(:,c) = sourceState(p)%p(s)%RK4dotState(:,c) & + + weight(n)*sourceState(p)%p(s)%dotState(:,c) enddo endif enddo; enddo; enddo From a09036ff4824531e4faebf787752bca6b60fdfbb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 00:11:10 +0100 Subject: [PATCH 331/372] on-the-fly initialization --- src/crystallite.f90 | 79 ++++++++++----------------------------------- 1 file changed, 17 insertions(+), 62 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b47f3334f..7767eb6f3 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1893,19 +1893,13 @@ subroutine integrateStateRK4() use, intrinsic :: & IEEE_arithmetic use mesh, only: & - mesh_element, & - mesh_NcpElems + mesh_element use material, only: & homogenization_Ngrains, & plasticState, & sourceState, & phase_Nsources, & phaseAt, phasememberAt - use config, only: & - material_Nphase - use constitutive, only: & - constitutive_collectDotState, & - constitutive_microstructure implicit none real(pReal), dimension(4), parameter :: & @@ -1920,65 +1914,28 @@ subroutine integrateStateRK4() c, & n, & s - integer(pInt), dimension(2) :: eIter ! bounds for element iteration - integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration - gIter ! bounds for grain iteration - logical :: singleRun ! flag indicating computation for single (g,i,e) triple - - eIter = FEsolving_execElem(1:2) - do e = eIter(1),eIter(2) - iIter(1:2,e) = FEsolving_execIP(1:2,e) - gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] - enddo - - singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) - -!-------------------------------------------------------------------------------------------------- -! initialize dotState - if (.not. singleRun) then - do p = 1_pInt, material_Nphase - plasticState(p)%RK4dotState = 0.0_pReal - do s = 1_pInt, phase_Nsources(p) - sourceState(p)%p(s)%RK4dotState = 0.0_pReal - enddo - enddo - else - e = eIter(1) - i = iIter(1,e) - do g = gIter(1,e), gIter(2,e) - plasticState(phaseAt(g,i,e))%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal - do s = 1_pInt, phase_Nsources(phaseAt(g,i,e)) - sourceState(phaseAt(g,i,e))%p(s)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal - enddo - enddo - endif call update_dotState(1.0_pReal) -!-------------------------------------------------------------------------------------------------- -! --- SECOND TO FOURTH RUNGE KUTTA STEP PLUS FINAL INTEGRATION --- do n = 1_pInt,4_pInt - ! --- state update --- - !$OMP PARALLEL - !$OMP DO PRIVATE(p,c) + !$OMP PARALLEL DO PRIVATE(p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) - plasticState(p)%RK4dotState(:,c) = plasticState(p)%RK4dotState(:,c) & - + weight(n)*plasticState(p)%dotState(:,c) + 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) - sourceState(p)%p(s)%RK4dotState(:,c) = sourceState(p)%p(s)%RK4dotState(:,c) & - + weight(n)*sourceState(p)%p(s)%dotState(:,c) + 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) enddo endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO call update_state(TIMESTEPFRACTION(n)) call update_deltaState @@ -1988,9 +1945,8 @@ subroutine integrateStateRK4() ! --- dot state and RK dot state--- first3steps: if (n < 4) then - call update_dotState(timeStepFraction(n)) + call update_dotState(TIMESTEPFRACTION(n)) endif first3steps - enddo @@ -2458,9 +2414,8 @@ subroutine update_deltaState i, & !< integration point index in ip loop g, & !< grain index in grain loop p, & - mySize, & + mySize, & myOffset, & - mySource, & c, & s logical :: & @@ -2469,7 +2424,7 @@ subroutine update_deltaState nonlocalStop = .false. - !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize,mySource,NaN) + !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -2489,15 +2444,15 @@ subroutine update_deltaState 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 mySource = 1_pInt, phase_Nsources(p) - myOffset = sourceState(p)%p(mySource)%offsetDeltaState - mySize = sourceState(p)%p(mySource)%sizeDeltaState - NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySize,c))) + do s = 1_pInt, 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(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(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) endif enddo endif From 77f1f45c231d4bcfd4dd3b6844d1cd7cbf4e1c32 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 00:17:04 +0100 Subject: [PATCH 332/372] just figured out that RK4 integrator is totally broken readable code helps ;) --- src/crystallite.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 7767eb6f3..a5f7592d6 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1888,6 +1888,7 @@ end subroutine integrateStateAdaptiveEuler !-------------------------------------------------------------------------------------------------- !> @brief integrate stress, state with 4th order explicit Runge Kutta method +! ToDo: This is totally BROKEN: RK4dotState is never used!!! !-------------------------------------------------------------------------------------------------- subroutine integrateStateRK4() use, intrinsic :: & @@ -1941,7 +1942,6 @@ subroutine integrateStateRK4() call update_deltaState call update_dependentState call update_stress(TIMESTEPFRACTION(n)) - ! --- dot state and RK dot state--- first3steps: if (n < 4) then From 5908e3fd3486e1584081908ab56cfc5d1ad3a022 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 06:44:26 +0100 Subject: [PATCH 333/372] wrong tolerance selection --- src/crystallite.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index a5f7592d6..b29ede160 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1637,7 +1637,7 @@ subroutine integrateStateFPI() + plasticState(p)%previousDotState(:,c) * (1.0_pReal - zeta) crystallite_converged(g,i,e) = all(abs(residuum_plastic(1:sizeDotState)) & - < min(plasticState(p)%aTolState(1:sizeDotState), & + < max(plasticState(p)%aTolState(1:sizeDotState), & abs(plasticState(p)%state(1:sizeDotState,c)*rTol_crystalliteState))) @@ -1661,7 +1661,7 @@ subroutine integrateStateFPI() crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & all(abs(residuum_source(1:sizeDotState)) & - < min(sourceState(p)%p(s)%aTolState(1:sizeDotState), & + < max(sourceState(p)%p(s)%aTolState(1:sizeDotState), & abs(sourceState(p)%p(s)%state(1:sizeDotState,c)*rTol_crystalliteState))) enddo endif From 462b1b7c189e8370c9930736b15ffc8ed22306f9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 06:47:36 +0100 Subject: [PATCH 334/372] sorted according to importance --- src/crystallite.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b29ede160..0150d68b0 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1723,7 +1723,7 @@ subroutine integrateStateFPI() dot_prod12 = dot_product(current - previous, previous - previous2) dot_prod22 = dot_product(previous - previous2, previous - previous2) - if (dot_prod22 > 0.0_pReal .and. (dot_prod12 < 0.0_pReal .or. dot_product(current,previous) < 0.0_pReal)) then + if ((dot_product(current,previous) < 0.0_pReal .or. dot_prod12 < 0.0_pReal) .and. dot_prod22 > 0.0_pReal) then damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) else damper = 1.0_pReal From 13af9fd3da8cfea3fe525c771b43da0760219d16 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 30 Jan 2019 09:04:55 +0100 Subject: [PATCH 335/372] [skip ci] updated version information after successful test of v2.0.2-1634-g370b23d5 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 82ddb5e1a..cd40c2f04 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1614-g8764c615 +v2.0.2-1634-g370b23d5 From ca7c105f363c80d49bce0fc5b9fd9add335961cf Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 08:56:16 +0100 Subject: [PATCH 336/372] only one loop needed --- src/crystallite.f90 | 35 +++++++++++------------------------ 1 file changed, 11 insertions(+), 24 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 0150d68b0..b0f1c1f94 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2038,46 +2038,33 @@ subroutine integrateStateRKCK45() ! --- state update --- - !$OMP PARALLEL - !$OMP DO PRIVATE(p,cc) + !$OMP PARALLEL DO PRIVATE(p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) - plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) ! store Runge-Kutta dotState + plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) + plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) + do mySource = 1_pInt, phase_Nsources(p) sourceState(p)%p(mySource)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(p,cc,n) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - - plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) - do mySource = 1_pInt, phase_Nsources(p) sourceState(p)%p(mySource)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(mySource)%RKCK45dotState(1,:,cc) enddo + do n = 2_pInt, stage - plasticState(p)%dotState(:,cc) = & - plasticState(p)%dotState(:,cc) + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) + plasticState(p)%dotState(:,cc) = plasticState(p)%dotState(:,cc) & + + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%dotState(:,cc) = & - sourceState(p)%p(mySource)%dotState(:,cc) + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) + sourceState(p)%p(mySource)%dotState(:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) & + + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) enddo enddo + endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO call update_state(1.0_pReal) !MD: 1.0 correct? call update_deltaState From df6ec59f76cdfa25e69e8e80486de4d47b56787b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 09:11:12 +0100 Subject: [PATCH 337/372] use "s" for source --- src/crystallite.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b0f1c1f94..de535e8c2 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2008,7 +2008,7 @@ subroutine integrateStateRKCK45() i, & ! integration point index in ip loop g, & ! grain index in grain loop stage, & ! stage index in integration stage loop - s, & ! state index + u, & ! state index n, & p, & cc, & @@ -2043,8 +2043,8 @@ subroutine integrateStateRKCK45() do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) + p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) + plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) @@ -2134,7 +2134,7 @@ subroutine integrateStateRKCK45() !$OMP PARALLEL ! --- relative residui and state convergence --- - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,u) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) @@ -2142,15 +2142,15 @@ subroutine integrateStateRKCK45() p = phaseAt(g,i,e) cc = phasememberAt(g,i,e) mySizePlasticDotState = plasticState(p)%sizeDotState - forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(s,cc)) > 0.0_pReal) & - relPlasticStateResiduum(s,g,i,e) = & - plasticStateResiduum(s,g,i,e) / plasticState(p)%state(s,cc) + forall (u = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & + relPlasticStateResiduum(u,g,i,e) = & + plasticStateResiduum(u,g,i,e) / plasticState(p)%state(u,cc) do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(s,cc)) > 0.0_pReal) & - relSourceStateResiduum(s,mySource,g,i,e) = & - sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%state(s,cc) + forall (u = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(u,cc)) > 0.0_pReal) & + relSourceStateResiduum(u,mySource,g,i,e) = & + sourceStateResiduum(u,mySource,g,i,e) / sourceState(p)%p(mySource)%state(u,cc) enddo crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & rTol_crystalliteState .or. & From 31906e3ebd70ea033e9f7fb652cd6280278f1fbd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 09:21:33 +0100 Subject: [PATCH 338/372] no need for 2 loops --- src/crystallite.f90 | 47 +++++++++++++++++---------------------------- 1 file changed, 18 insertions(+), 29 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index de535e8c2..3239f12c4 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2016,6 +2016,8 @@ subroutine integrateStateRKCK45() mySizePlasticDotState, & ! size of dot States mySizeSourceDotState + ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler + ! ToDo: MD: rel residuu don't have to be pointwise real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & @@ -2080,54 +2082,41 @@ subroutine integrateStateRKCK45() relPlasticStateResiduum = 0.0_pReal relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL - !$OMP DO PRIVATE(p,cc) + !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) ! store Runge-Kutta dotState - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState - enddo - endif - enddo; enddo; enddo - !$OMP ENDDO - - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) - - ! --- absolute residuum in state --- - mySizePlasticDotState = plasticState(p)%sizeDotState + p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) + + mySizePlasticDotState = plasticState(p)%sizeDotState + + plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)),DB) & * crystallite_subdt(g,i,e) + + plasticState(p)%dotState(:,cc) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) + do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + + sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & * crystallite_subdt(g,i,e) - enddo - ! --- dot state --- - plasticState(p)%dotState(:,cc) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) - do mySource = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState sourceState(p)%p(mySource)%dotState(:,cc) = & matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) enddo + endif enddo; enddo; enddo - !$OMP ENDDO - !$OMP END PARALLEL + !$OMP END PARALLEL DO call update_state(1.0_pReal) From 46be595ea803004d09a157c440a2848ad33e7f9e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:28:47 +0100 Subject: [PATCH 339/372] no need to store relative residual for all points --- src/crystallite.f90 | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 3239f12c4..d24b16dbf 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1787,18 +1787,19 @@ subroutine integrateStateAdaptiveEuler() s, & sizeDotState - ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler - ! ToDo: MD: rel residuu don't have to be pointwise - -real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - residuum_plastic, & - residuum_plastic_rel + residuum_plastic real(pReal), dimension(constitutive_source_maxSizeDotState,& maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - residuum_source_rel, & residuum_source + + real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & + residuum_plastic_rel + real(pReal), dimension(constitutive_source_maxSizeDotState) :: & + residuum_source_rel !-------------------------------------------------------------------------------------------------- ! contribution to state and relative residui and from Euler integration @@ -1828,10 +1829,10 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & enddo; enddo; enddo !$OMP END PARALLEL DO - call update_deltaState - call update_dependentState - call update_stress(1.0_pReal) - call update_dotState(1.0_pReal) + call update_deltaState + call update_dependentState + call update_stress(1.0_pReal) + call update_dotState(1.0_pReal) !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) @@ -1840,20 +1841,18 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState - - ! --- contribution of heun step to absolute residui --- residuum_plastic(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) where(dNeq0(plasticState(p)%dotState(1:sizeDotState,c))) - residuum_plastic_rel(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & - / plasticState(p)%dotState(1:sizeDotState,c) + residuum_plastic_rel(1:sizeDotState) = residuum_plastic(1:sizeDotState,g,i,e) & + / plasticState(p)%dotState(1:sizeDotState,c) else where - residuum_plastic_rel(1:sizeDotState,g,i,e) = 0.0_pReal + residuum_plastic_rel(1:sizeDotState) = 0.0_pReal end where - crystallite_converged(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState,g,i,e)) < & + crystallite_converged(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState)) < & rTol_crystalliteState .or. & abs(residuum_plastic(1:sizeDotState,g,i,e)) < & plasticState(p)%aTolState(1:sizeDotState)) @@ -1865,14 +1864,14 @@ real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) where(dNeq0(sourceState(p)%p(s)%dotState(1:sizeDotState,c))) - residuum_source_rel(1:sizeDotState,s,g,i,e) = residuum_source(1:sizeDotState,s,g,i,e) & - / sourceState(p)%p(s)%dotState(1:sizeDotState,c) + residuum_source_rel(1:sizeDotState) = residuum_source(1:sizeDotState,s,g,i,e) & + / sourceState(p)%p(s)%dotState(1:sizeDotState,c) else where - residuum_source_rel(1:SizeDotState,s,g,i,e) = 0.0_pReal + residuum_source_rel(1:SizeDotState) = 0.0_pReal end where - crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & - all(abs(residuum_source_rel(1:sizeDotState,s,g,i,e)) < & + crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & + all(abs(residuum_source_rel(1:sizeDotState)) < & rTol_crystalliteState .or. & abs(residuum_source(1:sizeDotState,s,g,i,e)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState)) From 0745d7ebc20ab6803869d88ca88cb56a8afb0aca Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:33:57 +0100 Subject: [PATCH 340/372] convergence flag is set only later --- src/crystallite.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index d24b16dbf..053aa35eb 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1809,7 +1809,7 @@ subroutine integrateStateAdaptiveEuler() do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState @@ -1838,7 +1838,7 @@ subroutine integrateStateAdaptiveEuler() do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState From 72c4f2b25fae73f0c9ec665fbb1132571f80aa51 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:37:18 +0100 Subject: [PATCH 341/372] same names everywhere if possible --- src/crystallite.f90 | 54 ++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 053aa35eb..80e1a7ed6 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2011,7 +2011,7 @@ subroutine integrateStateRKCK45() n, & p, & cc, & - mySource, & + s, & mySizePlasticDotState, & ! size of dot States mySizeSourceDotState @@ -2049,17 +2049,17 @@ subroutine integrateStateRKCK45() plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) - sourceState(p)%p(mySource)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(mySource)%RKCK45dotState(1,:,cc) + do s = 1_pInt, 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 plasticState(p)%dotState(:,cc) = plasticState(p)%dotState(:,cc) & + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) - do mySource = 1_pInt, phase_Nsources(p) - sourceState(p)%p(mySource)%dotState(:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) & - + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) + do s = 1_pInt, 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 enddo @@ -2099,18 +2099,18 @@ subroutine integrateStateRKCK45() plasticState(p)%dotState(:,cc) = & matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState - sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState + sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) ! store Runge-Kutta dotState - sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & - matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & + sourceStateResiduum(1:mySizeSourceDotState,s,g,i,e) = & + matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & * crystallite_subdt(g,i,e) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - sourceState(p)%p(mySource)%dotState(:,cc) = & - matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sourceState(p)%p(s)%dotState(:,cc) = & + matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) enddo endif @@ -2127,30 +2127,30 @@ subroutine integrateStateRKCK45() do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e) - cc = phasememberAt(g,i,e) + p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState forall (u = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & relPlasticStateResiduum(u,g,i,e) = & plasticStateResiduum(u,g,i,e) / plasticState(p)%state(u,cc) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState - forall (u = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(u,cc)) > 0.0_pReal) & - relSourceStateResiduum(u,mySource,g,i,e) = & - sourceStateResiduum(u,mySource,g,i,e) / sourceState(p)%p(mySource)%state(u,cc) + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + forall (u = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & + relSourceStateResiduum(u,s,g,i,e) = & + sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) enddo crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & rTol_crystalliteState .or. & abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & plasticState(p)%aTolState(1:mySizePlasticDotState)) - do mySource = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + all(abs(relSourceStateResiduum(1:mySizeSourceDotState,s,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & - sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + abs(sourceStateResiduum(1:mySizeSourceDotState,s,g,i,e)) < & + sourceState(p)%p(s)%aTolState(1:mySizeSourceDotState)) enddo endif enddo; enddo; enddo From 0876787e3c56bd201214d599a74c1ce1c11ef9ce Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:46:53 +0100 Subject: [PATCH 342/372] avoid loops --- src/crystallite.f90 | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 80e1a7ed6..cc261726f 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1976,10 +1976,8 @@ subroutine integrateStateRKCK45() phaseAt, phasememberAt, & homogenization_maxNgrains use constitutive, only: & - constitutive_collectDotState, & constitutive_plasticity_maxSizeDotState, & - constitutive_source_maxSizeDotState, & - constitutive_microstructure + constitutive_source_maxSizeDotState implicit none real(pReal), dimension(5,5), parameter :: & @@ -2059,7 +2057,7 @@ subroutine integrateStateRKCK45() + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) do s = 1_pInt, 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) + + A(n,stage) * sourceState(p)%p(s)%RKCK45dotState(n,:,cc) enddo enddo @@ -2088,7 +2086,7 @@ subroutine integrateStateRKCK45() if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState + mySizePlasticDotState = plasticState(p)%sizeDotState plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) @@ -2133,18 +2131,18 @@ subroutine integrateStateRKCK45() forall (u = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & relPlasticStateResiduum(u,g,i,e) = & plasticStateResiduum(u,g,i,e) / plasticState(p)%state(u,cc) + + crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) do s = 1_pInt, phase_Nsources(p) mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState forall (u = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & relSourceStateResiduum(u,s,g,i,e) = & sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) - enddo - crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) - do s = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & all(abs(relSourceStateResiduum(1:mySizeSourceDotState,s,g,i,e)) < & From 4ec0fd70a2574e2caa84497fea165d53fcffb608 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:48:59 +0100 Subject: [PATCH 343/372] only one variable needed --- src/crystallite.f90 | 47 ++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index cc261726f..81b730aad 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2010,8 +2010,7 @@ subroutine integrateStateRKCK45() p, & cc, & s, & - mySizePlasticDotState, & ! size of dot States - mySizeSourceDotState + sizeDotState ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler ! ToDo: MD: rel residuu don't have to be pointwise @@ -2079,36 +2078,36 @@ subroutine integrateStateRKCK45() relPlasticStateResiduum = 0.0_pReal relSourceStateResiduum = 0.0_pReal - !$OMP PARALLEL DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState + sizeDotState = plasticState(p)%sizeDotState plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) - plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)),DB) & + plasticStateResiduum(1:sizeDotState,g,i,e) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & * crystallite_subdt(g,i,e) plasticState(p)%dotState(:,cc) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)), B) do s = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sizeDotState = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) ! store Runge-Kutta dotState - sourceStateResiduum(1:mySizeSourceDotState,s,g,i,e) = & - matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & + sourceStateResiduum(1:sizeDotState,s,g,i,e) = & + matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & * crystallite_subdt(g,i,e) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sizeDotState = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%dotState(:,cc) = & - matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) + matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:sizeDotState,cc)),B) enddo endif @@ -2120,35 +2119,35 @@ subroutine integrateStateRKCK45() !$OMP PARALLEL ! --- relative residui and state convergence --- - !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,u) + !$OMP DO PRIVATE(sizeDotState,p,cc,u) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) - mySizePlasticDotState = plasticState(p)%sizeDotState - forall (u = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & + sizeDotState = plasticState(p)%sizeDotState + forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & relPlasticStateResiduum(u,g,i,e) = & plasticStateResiduum(u,g,i,e) / plasticState(p)%state(u,cc) - crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & - plasticState(p)%aTolState(1:mySizePlasticDotState)) + abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState - forall (u = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & + sizeDotState = sourceState(p)%p(s)%sizeDotState + forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & relSourceStateResiduum(u,s,g,i,e) = & sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) - mySizeSourceDotState = sourceState(p)%p(s)%sizeDotState + sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(relSourceStateResiduum(1:mySizeSourceDotState,s,g,i,e)) < & + all(abs(relSourceStateResiduum(1:sizeDotState,s,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:mySizeSourceDotState,s,g,i,e)) < & - sourceState(p)%p(s)%aTolState(1:mySizeSourceDotState)) + abs(sourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif enddo; enddo; enddo From fd069a96cdc68941a44de7aca9083a2b03b5d5d9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 10:51:24 +0100 Subject: [PATCH 344/372] unifying name --- src/crystallite.f90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 81b730aad..f9f469a5d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2017,13 +2017,13 @@ subroutine integrateStateRKCK45() real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - plasticStateResiduum, & ! residuum from evolution in microstructure - relPlasticStateResiduum ! relative residuum from evolution in microstructure + residuum_plastic, & ! residuum from evolution in microstructure + residuum_plastic_rel ! relative residuum from evolution in microstructure real(pReal), dimension(constitutive_source_maxSizeDotState, & maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - sourceStateResiduum, & ! residuum from evolution in microstructure - relSourceStateResiduum ! relative residuum from evolution in microstructure + residuum_source, & ! residuum from evolution in microstructure + residuum_source_rel ! relative residuum from evolution in microstructure @@ -2076,8 +2076,8 @@ subroutine integrateStateRKCK45() !-------------------------------------------------------------------------------------------------- ! --- STATE UPDATE WITH ERROR ESTIMATE FOR STATE --- - relPlasticStateResiduum = 0.0_pReal - relSourceStateResiduum = 0.0_pReal + residuum_plastic_rel = 0.0_pReal + residuum_source_rel = 0.0_pReal !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) @@ -2089,7 +2089,7 @@ subroutine integrateStateRKCK45() plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) - plasticStateResiduum(1:sizeDotState,g,i,e) = & + residuum_plastic(1:sizeDotState,g,i,e) = & matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & * crystallite_subdt(g,i,e) @@ -2101,7 +2101,7 @@ subroutine integrateStateRKCK45() sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) ! store Runge-Kutta dotState - sourceStateResiduum(1:sizeDotState,s,g,i,e) = & + residuum_source(1:sizeDotState,s,g,i,e) = & matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & * crystallite_subdt(g,i,e) @@ -2128,25 +2128,25 @@ subroutine integrateStateRKCK45() sizeDotState = plasticState(p)%sizeDotState forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & - relPlasticStateResiduum(u,g,i,e) = & - plasticStateResiduum(u,g,i,e) / plasticState(p)%state(u,cc) + residuum_plastic_rel(u,g,i,e) = & + residuum_plastic(u,g,i,e) / plasticState(p)%state(u,cc) - crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:sizeDotState,g,i,e)) < & + crystallite_todo(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState,g,i,e)) < & rTol_crystalliteState .or. & - abs(plasticStateResiduum(1:sizeDotState,g,i,e)) < & + abs(residuum_plastic(1:sizeDotState,g,i,e)) < & plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & - relSourceStateResiduum(u,s,g,i,e) = & - sourceStateResiduum(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) + residuum_source_rel(u,s,g,i,e) = & + residuum_source(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(relSourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + all(abs(residuum_source_rel(1:sizeDotState,s,g,i,e)) < & rTol_crystalliteState .or. & - abs(sourceStateResiduum(1:sizeDotState,s,g,i,e)) < & + abs(residuum_source(1:sizeDotState,s,g,i,e)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif From 3dd21177a0464faf46aca285cb7d3f8ca7325743 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 11:04:49 +0100 Subject: [PATCH 345/372] no need to store relative residual pointwise --- src/crystallite.f90 | 76 ++++++++++++++++++++++----------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index f9f469a5d..0a190e364 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1890,8 +1890,6 @@ end subroutine integrateStateAdaptiveEuler ! ToDo: This is totally BROKEN: RK4dotState is never used!!! !-------------------------------------------------------------------------------------------------- subroutine integrateStateRK4() - use, intrinsic :: & - IEEE_arithmetic use mesh, only: & mesh_element use material, only: & @@ -1960,8 +1958,8 @@ end subroutine integrateStateRK4 !> adaptive step size (use 5th order solution to advance = "local extrapolation") !-------------------------------------------------------------------------------------------------- subroutine integrateStateRKCK45() - use, intrinsic :: & - IEEE_arithmetic + use prec, only: & + dNeq0 use numerics, only: & rTol_crystalliteState use mesh, only: & @@ -2005,26 +2003,25 @@ subroutine integrateStateRKCK45() i, & ! integration point index in ip loop g, & ! grain index in grain loop stage, & ! stage index in integration stage loop - u, & ! state index n, & p, & cc, & s, & sizeDotState - ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler - ! ToDo: MD: rel residuu don't have to be pointwise + ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of RKCK45 real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - residuum_plastic, & ! residuum from evolution in microstructure - residuum_plastic_rel ! relative residuum from evolution in microstructure + residuum_plastic ! relative residuum from evolution in microstructure real(pReal), dimension(constitutive_source_maxSizeDotState, & maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & - residuum_source, & ! residuum from evolution in microstructure - residuum_source_rel ! relative residuum from evolution in microstructure - + residuum_source ! relative residuum from evolution in microstructure + real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & + residuum_plastic_rel + real(pReal), dimension(constitutive_source_maxSizeDotState) :: & + residuum_source_rel call update_dotState(1.0_pReal) @@ -2076,8 +2073,6 @@ subroutine integrateStateRKCK45() !-------------------------------------------------------------------------------------------------- ! --- STATE UPDATE WITH ERROR ESTIMATE FOR STATE --- - residuum_plastic_rel = 0.0_pReal - residuum_source_rel = 0.0_pReal !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) @@ -2116,43 +2111,48 @@ subroutine integrateStateRKCK45() call update_state(1.0_pReal) -!$OMP PARALLEL ! --- relative residui and state convergence --- - !$OMP DO PRIVATE(sizeDotState,p,cc,u) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) - if (crystallite_todo(g,i,e)) then - p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) + !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) - sizeDotState = plasticState(p)%sizeDotState - forall (u = 1_pInt:sizeDotState, abs(plasticState(p)%state(u,cc)) > 0.0_pReal) & - residuum_plastic_rel(u,g,i,e) = & - residuum_plastic(u,g,i,e) / plasticState(p)%state(u,cc) + sizeDotState = plasticState(p)%sizeDotState + where(dNeq0(plasticState(p)%dotState(1:sizeDotState,cc))) + residuum_plastic_rel(1:sizeDotState) = residuum_plastic(1:sizeDotState,g,i,e) & + / plasticState(p)%state(1:sizeDotState,cc) + else where + residuum_plastic_rel(1:sizeDotState) = 0.0_pReal + end where + - crystallite_todo(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState,g,i,e)) < & - rTol_crystalliteState .or. & - abs(residuum_plastic(1:sizeDotState,g,i,e)) < & - plasticState(p)%aTolState(1:sizeDotState)) + crystallite_todo(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState)) < & + rTol_crystalliteState .or. & + abs(residuum_plastic(1:sizeDotState,g,i,e)) < & + plasticState(p)%aTolState(1:sizeDotState)) - do s = 1_pInt, phase_Nsources(p) - sizeDotState = sourceState(p)%p(s)%sizeDotState - forall (u = 1_pInt:sizeDotState,abs(sourceState(p)%p(s)%state(u,cc)) > 0.0_pReal) & - residuum_source_rel(u,s,g,i,e) = & - residuum_source(u,s,g,i,e) / sourceState(p)%p(s)%state(u,cc) + do s = 1_pInt, phase_Nsources(p) + sizeDotState = sourceState(p)%p(s)%sizeDotState + + where(dNeq0(sourceState(p)%p(s)%dotState(1:sizeDotState,cc))) + residuum_source_rel(1:sizeDotState) = residuum_source(1:sizeDotState,s,g,i,e) & + / sourceState(p)%p(s)%state(1:sizeDotState,cc) + else where + residuum_source_rel(1:SizeDotState) = 0.0_pReal + end where - sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(residuum_source_rel(1:sizeDotState,s,g,i,e)) < & + all(abs(residuum_source_rel(1:sizeDotState)) < & rTol_crystalliteState .or. & abs(residuum_source(1:sizeDotState,s,g,i,e)) < & sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif enddo; enddo; enddo - !$OMP ENDDO -!$OMP END PARALLEL + !$OMP END PARALLEL DO call update_deltaState call update_dependentState From 39e766bba006e52742a952fbf523e413fa02750d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 12:36:02 +0100 Subject: [PATCH 346/372] improved readability --- src/crystallite.f90 | 139 +++++++++++++++++++++++--------------------- 1 file changed, 73 insertions(+), 66 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 0a190e364..210bf8198 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1758,10 +1758,6 @@ end subroutine integrateStateEuler !> @brief integrate stress, state with 1st order Euler method with adaptive step size !-------------------------------------------------------------------------------------------------- subroutine integrateStateAdaptiveEuler() - use prec, only: & - dNeq0 - use numerics, only: & - rTol_crystalliteState use mesh, only: & mesh_element, & mesh_NcpElems, & @@ -1795,11 +1791,6 @@ subroutine integrateStateAdaptiveEuler() maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & residuum_source - - real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & - residuum_plastic_rel - real(pReal), dimension(constitutive_source_maxSizeDotState) :: & - residuum_source_rel !-------------------------------------------------------------------------------------------------- ! contribution to state and relative residui and from Euler integration @@ -1845,42 +1836,55 @@ subroutine integrateStateAdaptiveEuler() residuum_plastic(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - where(dNeq0(plasticState(p)%dotState(1:sizeDotState,c))) - residuum_plastic_rel(1:sizeDotState) = residuum_plastic(1:sizeDotState,g,i,e) & - / plasticState(p)%dotState(1:sizeDotState,c) - else where - residuum_plastic_rel(1:sizeDotState) = 0.0_pReal - end where - - crystallite_converged(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState)) < & - rTol_crystalliteState .or. & - abs(residuum_plastic(1:sizeDotState,g,i,e)) < & - plasticState(p)%aTolState(1:sizeDotState)) + crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & + plasticState(p)%dotState(1:sizeDotState,c), & + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState residuum_source(1:sizeDotState,s,g,i,e) = residuum_source(1:sizeDotState,s,g,i,e) & + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) - - where(dNeq0(sourceState(p)%p(s)%dotState(1:sizeDotState,c))) - residuum_source_rel(1:sizeDotState) = residuum_source(1:sizeDotState,s,g,i,e) & - / sourceState(p)%p(s)%dotState(1:sizeDotState,c) - else where - residuum_source_rel(1:SizeDotState) = 0.0_pReal - end where - crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & - all(abs(residuum_source_rel(1:sizeDotState)) < & - rTol_crystalliteState .or. & - abs(residuum_source(1:sizeDotState,s,g,i,e)) < & - sourceState(p)%p(s)%aTolState(1:sizeDotState)) - enddo + crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and.& + converged(residuum_source(1:sizeDotState,s,g,i,e), & + sourceState(p)%p(s)%dotState(1:sizeDotState,c), & + sourceState(p)%p(s)%aTolState(1:sizeDotState)) + enddo + endif enddo; enddo; enddo !$OMP END PARALLEL DO if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck + + contains + + !-------------------------------------------------------------------------------------------------- + !> @brief determines whether a point is converged + !-------------------------------------------------------------------------------------------------- + logical pure function converged(residuum,dotState,absoluteTolerance) + use prec, only: & + dNeq0 + use numerics, only: & + rTol_crystalliteState + + implicit none + real(pReal), dimension(:), intent(in) ::& + residuum, dotState, absoluteTolerance + real(pReal), dimension(size(residuum,1)) ::& + residuum_rel + + where(dNeq0(dotState)) + residuum_rel = residuum/dotState + else where + residuum_rel = 0.0_pReal + end where + + converged = all(abs(residuum_rel) < rTol_crystalliteState .or. & + abs(residuum) < absoluteTolerance) + + end function converged end subroutine integrateStateAdaptiveEuler @@ -1958,10 +1962,6 @@ end subroutine integrateStateRK4 !> adaptive step size (use 5th order solution to advance = "local extrapolation") !-------------------------------------------------------------------------------------------------- subroutine integrateStateRKCK45() - use prec, only: & - dNeq0 - use numerics, only: & - rTol_crystalliteState use mesh, only: & mesh_element, & mesh_NcpElems, & @@ -2018,15 +2018,10 @@ subroutine integrateStateRKCK45() maxval(phase_Nsources), & homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & residuum_source ! relative residuum from evolution in microstructure - real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & - residuum_plastic_rel - real(pReal), dimension(constitutive_source_maxSizeDotState) :: & - residuum_source_rel call update_dotState(1.0_pReal) - ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- do stage = 1_pInt,5_pInt @@ -2121,34 +2116,18 @@ subroutine integrateStateRKCK45() p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState - where(dNeq0(plasticState(p)%dotState(1:sizeDotState,cc))) - residuum_plastic_rel(1:sizeDotState) = residuum_plastic(1:sizeDotState,g,i,e) & - / plasticState(p)%state(1:sizeDotState,cc) - else where - residuum_plastic_rel(1:sizeDotState) = 0.0_pReal - end where - - - crystallite_todo(g,i,e) = all(abs(residuum_plastic_rel(1:sizeDotState)) < & - rTol_crystalliteState .or. & - abs(residuum_plastic(1:sizeDotState,g,i,e)) < & - plasticState(p)%aTolState(1:sizeDotState)) + + crystallite_todo(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & + plasticState(p)%dotState(1:sizeDotState,cc), & + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState - where(dNeq0(sourceState(p)%p(s)%dotState(1:sizeDotState,cc))) - residuum_source_rel(1:sizeDotState) = residuum_source(1:sizeDotState,s,g,i,e) & - / sourceState(p)%p(s)%state(1:sizeDotState,cc) - else where - residuum_source_rel(1:SizeDotState) = 0.0_pReal - end where - - crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & - all(abs(residuum_source_rel(1:sizeDotState)) < & - rTol_crystalliteState .or. & - abs(residuum_source(1:sizeDotState,s,g,i,e)) < & - sourceState(p)%p(s)%aTolState(1:sizeDotState)) + crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and.& + converged(residuum_source(1:sizeDotState,s,g,i,e), & + sourceState(p)%p(s)%dotState(1:sizeDotState,cc), & + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif enddo; enddo; enddo @@ -2159,6 +2138,34 @@ subroutine integrateStateRKCK45() call update_stress(1.0_pReal) call setConvergenceFlag if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck + + contains + + !-------------------------------------------------------------------------------------------------- + !> @brief determines whether a point is converged + !-------------------------------------------------------------------------------------------------- + logical pure function converged(residuum,dotState,absoluteTolerance) + use prec, only: & + dNeq0 + use numerics, only: & + rTol_crystalliteState + + implicit none + real(pReal), dimension(:), intent(in) ::& + residuum, dotState, absoluteTolerance + real(pReal), dimension(size(residuum,1)) ::& + residuum_rel + + where(dNeq0(dotState)) + residuum_rel = residuum/dotState + else where + residuum_rel = 0.0_pReal + end where + + converged = all(abs(residuum_rel) < rTol_crystalliteState .or. & + abs(residuum) < absoluteTolerance) + + end function converged end subroutine integrateStateRKCK45 From 64b89484d2b75693b15be359427bb22244b336aa Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 12:56:02 +0100 Subject: [PATCH 347/372] logic better visible --- src/crystallite.f90 | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 210bf8198..dc3e5b154 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1872,17 +1872,16 @@ subroutine integrateStateAdaptiveEuler() implicit none real(pReal), dimension(:), intent(in) ::& residuum, dotState, absoluteTolerance - real(pReal), dimension(size(residuum,1)) ::& - residuum_rel - + logical, dimension(size(residuum,1)) ::& + converged_array + where(dNeq0(dotState)) - residuum_rel = residuum/dotState + converged_array = abs(residuum) < absoluteTolerance .or. (abs(residuum/dotState) < rTol_crystalliteState) else where - residuum_rel = 0.0_pReal + converged_array = .true. end where - converged = all(abs(residuum_rel) < rTol_crystalliteState .or. & - abs(residuum) < absoluteTolerance) + converged = all(converged_array) end function converged @@ -2153,17 +2152,16 @@ subroutine integrateStateRKCK45() implicit none real(pReal), dimension(:), intent(in) ::& residuum, dotState, absoluteTolerance - real(pReal), dimension(size(residuum,1)) ::& - residuum_rel - + logical, dimension(size(residuum,1)) ::& + converged_array + where(dNeq0(dotState)) - residuum_rel = residuum/dotState + converged_array = abs(residuum) < absoluteTolerance .or. (abs(residuum/dotState) < rTol_crystalliteState) else where - residuum_rel = 0.0_pReal + converged_array = .true. end where - converged = all(abs(residuum_rel) < rTol_crystalliteState .or. & - abs(residuum) < absoluteTolerance) + converged = all(converged_array) end function converged From 1d88057ce42c7069d5a0b5d6c7ff8c1f13d29589 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 13:24:35 +0100 Subject: [PATCH 348/372] avoid superflous variables --- src/crystallite.f90 | 60 ++++++++++++++++++++------------------------- 1 file changed, 27 insertions(+), 33 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index dc3e5b154..4adae2a19 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1836,9 +1836,9 @@ subroutine integrateStateAdaptiveEuler() residuum_plastic(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & + crystallite_converged(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & plasticState(p)%dotState(1:sizeDotState,c), & - plasticState(p)%aTolState(1:sizeDotState)) + plasticState(p)%aTolState(1:sizeDotState))) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState @@ -1847,9 +1847,9 @@ subroutine integrateStateAdaptiveEuler() + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and.& - converged(residuum_source(1:sizeDotState,s,g,i,e), & + all(converged(residuum_source(1:sizeDotState,s,g,i,e), & sourceState(p)%p(s)%dotState(1:sizeDotState,c), & - sourceState(p)%p(s)%aTolState(1:sizeDotState)) + sourceState(p)%p(s)%aTolState(1:sizeDotState))) enddo endif @@ -1863,25 +1863,22 @@ subroutine integrateStateAdaptiveEuler() !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure function converged(residuum,dotState,absoluteTolerance) + logical pure elemental function converged(residuum,dotState,absoluteTolerance) use prec, only: & - dNeq0 + dEq0 use numerics, only: & rTol_crystalliteState implicit none - real(pReal), dimension(:), intent(in) ::& + real(pReal), intent(in) ::& residuum, dotState, absoluteTolerance - logical, dimension(size(residuum,1)) ::& - converged_array - where(dNeq0(dotState)) - converged_array = abs(residuum) < absoluteTolerance .or. (abs(residuum/dotState) < rTol_crystalliteState) - else where - converged_array = .true. - end where - - converged = all(converged_array) + if (dEq0(dotState)) then + converged = .true. + else + converged = abs(residuum) < absoluteTolerance & + .or. abs(residuum/dotState) < rTol_crystalliteState + endif end function converged @@ -2116,17 +2113,17 @@ subroutine integrateStateRKCK45() sizeDotState = plasticState(p)%sizeDotState - crystallite_todo(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & + crystallite_todo(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & plasticState(p)%dotState(1:sizeDotState,cc), & - plasticState(p)%aTolState(1:sizeDotState)) + plasticState(p)%aTolState(1:sizeDotState))) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and.& - converged(residuum_source(1:sizeDotState,s,g,i,e), & + all(converged(residuum_source(1:sizeDotState,s,g,i,e), & sourceState(p)%p(s)%dotState(1:sizeDotState,cc), & - sourceState(p)%p(s)%aTolState(1:sizeDotState)) + sourceState(p)%p(s)%aTolState(1:sizeDotState))) enddo endif enddo; enddo; enddo @@ -2138,30 +2135,27 @@ subroutine integrateStateRKCK45() call setConvergenceFlag if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck - contains + contains !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure function converged(residuum,dotState,absoluteTolerance) + logical pure elemental function converged(residuum,dotState,absoluteTolerance) use prec, only: & - dNeq0 + dEq0 use numerics, only: & rTol_crystalliteState implicit none - real(pReal), dimension(:), intent(in) ::& + real(pReal), intent(in) ::& residuum, dotState, absoluteTolerance - logical, dimension(size(residuum,1)) ::& - converged_array - where(dNeq0(dotState)) - converged_array = abs(residuum) < absoluteTolerance .or. (abs(residuum/dotState) < rTol_crystalliteState) - else where - converged_array = .true. - end where - - converged = all(converged_array) + if (dEq0(dotState)) then + converged = .true. + else + converged = abs(residuum) < absoluteTolerance & + .or. abs(residuum/dotState) < rTol_crystalliteState + endif end function converged From fe88e5bf9cda3e38e2c7f46ce058052316f9b465 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 14:52:12 +0100 Subject: [PATCH 349/372] [skip ci] cleaning --- src/crystallite.f90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 4adae2a19..b089e2f77 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2085,13 +2085,12 @@ subroutine integrateStateRKCK45() do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState - sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) ! store Runge-Kutta dotState - + sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) + residuum_source(1:sizeDotState,s,g,i,e) = & matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & * crystallite_subdt(g,i,e) - sizeDotState = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%dotState(:,cc) = & matmul(transpose(sourceState(p)%p(s)%RKCK45dotState(1:6,1:sizeDotState,cc)),B) enddo @@ -2124,7 +2123,7 @@ subroutine integrateStateRKCK45() all(converged(residuum_source(1:sizeDotState,s,g,i,e), & sourceState(p)%p(s)%dotState(1:sizeDotState,cc), & sourceState(p)%p(s)%aTolState(1:sizeDotState))) - enddo + enddo endif enddo; enddo; enddo !$OMP END PARALLEL DO From e1c2747393392543bfee7cdcfe25a243d35116d9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 16:06:14 +0100 Subject: [PATCH 350/372] logic error for nonlocal --- src/crystallite.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b089e2f77..3ad592147 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -2340,7 +2340,7 @@ subroutine update_dotState(timeFraction) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) !$OMP FLUSH(nonlocalStop) - if (nonlocalStop .or. (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e))) then + if ((crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) .and. .not. nonlocalStop) then call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & crystallite_Fe, & crystallite_Fi(1:3,1:3,g,i,e), & @@ -2399,7 +2399,7 @@ subroutine update_deltaState do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do g = 1,homogenization_Ngrains(mesh_element(3,e)) !$OMP FLUSH(nonlocalStop) - if (nonlocalStop .or. (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e))) then + if ((crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) .and. .not. nonlocalStop) then call constitutive_collectDeltaState(math_6toSym33(crystallite_Tstar_v(1:6,g,i,e)), & crystallite_Fe(1:3,1:3,g,i,e), & crystallite_Fi(1:3,1:3,g,i,e), & From 3b13a1af6376314ef50f2f240bd2def7f7570c5e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 30 Jan 2019 17:04:58 +0100 Subject: [PATCH 351/372] calculated convergence criteria wrongly --- src/crystallite.f90 | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 3ad592147..749f202e4 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1837,7 +1837,7 @@ subroutine integrateStateAdaptiveEuler() + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) crystallite_converged(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & - plasticState(p)%dotState(1:sizeDotState,c), & + plasticState(p)%state(1:sizeDotState,c), & plasticState(p)%aTolState(1:sizeDotState))) do s = 1_pInt, phase_Nsources(p) @@ -1848,7 +1848,7 @@ subroutine integrateStateAdaptiveEuler() crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and.& all(converged(residuum_source(1:sizeDotState,s,g,i,e), & - sourceState(p)%p(s)%dotState(1:sizeDotState,c), & + sourceState(p)%p(s)%state(1:sizeDotState,c), & sourceState(p)%p(s)%aTolState(1:sizeDotState))) enddo @@ -1863,21 +1863,21 @@ subroutine integrateStateAdaptiveEuler() !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure elemental function converged(residuum,dotState,absoluteTolerance) + logical pure elemental function converged(residuum,state,aTol) use prec, only: & dEq0 use numerics, only: & - rTol_crystalliteState + rTol => rTol_crystalliteState implicit none real(pReal), intent(in) ::& - residuum, dotState, absoluteTolerance + residuum, state, aTol - if (dEq0(dotState)) then - converged = .true. + if (dEq0(state)) then + converged = .true. ! ToDo: intended behavior? Not rely on absoluteTolerance else - converged = abs(residuum) < absoluteTolerance & - .or. abs(residuum/dotState) < rTol_crystalliteState + converged = abs(residuum) < aTol & + .or. abs(residuum/state) < rTol endif end function converged @@ -2113,7 +2113,7 @@ subroutine integrateStateRKCK45() sizeDotState = plasticState(p)%sizeDotState crystallite_todo(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & - plasticState(p)%dotState(1:sizeDotState,cc), & + plasticState(p)%state(1:sizeDotState,cc), & plasticState(p)%aTolState(1:sizeDotState))) do s = 1_pInt, phase_Nsources(p) @@ -2121,7 +2121,7 @@ subroutine integrateStateRKCK45() crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and.& all(converged(residuum_source(1:sizeDotState,s,g,i,e), & - sourceState(p)%p(s)%dotState(1:sizeDotState,cc), & + sourceState(p)%p(s)%state(1:sizeDotState,cc), & sourceState(p)%p(s)%aTolState(1:sizeDotState))) enddo endif @@ -2139,21 +2139,21 @@ subroutine integrateStateRKCK45() !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure elemental function converged(residuum,dotState,absoluteTolerance) + logical pure elemental function converged(residuum,state,aTol) use prec, only: & dEq0 use numerics, only: & - rTol_crystalliteState + rTol => rTol_crystalliteState implicit none real(pReal), intent(in) ::& - residuum, dotState, absoluteTolerance + residuum, state, aTol - if (dEq0(dotState)) then - converged = .true. + if (dEq0(state)) then + converged = .true. ! ToDo: intended behavior? Not rely on absoluteTolerance else - converged = abs(residuum) < absoluteTolerance & - .or. abs(residuum/dotState) < rTol_crystalliteState + converged = abs(residuum) < aTol & + .or. abs(residuum/state) < rTol endif end function converged From 5eaeb37ea48d2d8b23721d981f24cc8a9a25eda7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 31 Jan 2019 05:17:46 +0100 Subject: [PATCH 352/372] just polishing --- src/crystallite.f90 | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 749f202e4..7c99c4d7a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -819,8 +819,8 @@ subroutine crystallite_stressTangent() crystallite_invFi(1:3,1:3,c,i,e)) & + math_mul33x33(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) + 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)) if (error) then @@ -1350,11 +1350,10 @@ 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) - dFe_dLp = - dt * dFe_dLp - dRLp_dLp = math_identity2nd(9_pInt) & - - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) + 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) + dFe_dLp = - dt * dFe_dLp + dRLp_dLp = math_identity2nd(9_pInt) & + - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & @@ -2076,11 +2075,11 @@ subroutine integrateStateRKCK45() plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) residuum_plastic(1:sizeDotState,g,i,e) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)),DB) & ! why transpose? Better to transpose constant DB * crystallite_subdt(g,i,e) plasticState(p)%dotState(:,cc) = & - matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)), B) + 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) sizeDotState = sourceState(p)%p(s)%sizeDotState From cbeb3dcff0133022622f1b16a2bf1375f463d4bf Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 31 Jan 2019 09:12:44 +0100 Subject: [PATCH 353/372] use the same formulation for convergence every where --- src/crystallite.f90 | 73 +++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 35 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 7c99c4d7a..f9ceab03c 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1535,11 +1535,8 @@ end function integrateStress !> using Fixed Point Iteration to adapt the stepsize !-------------------------------------------------------------------------------------------------- subroutine integrateStateFPI() - use, intrinsic :: & - IEEE_arithmetic use numerics, only: & - nState, & - rTol_crystalliteState + nState use mesh, only: & mesh_element use material, only: & @@ -1549,7 +1546,6 @@ subroutine integrateStateFPI() phase_Nsources, & homogenization_Ngrains use constitutive, only: & - constitutive_collectDotState, & constitutive_plasticity_maxSizeDotState, & constitutive_source_maxSizeDotState @@ -1635,9 +1631,9 @@ subroutine integrateStateFPI() plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * zeta & + plasticState(p)%previousDotState(:,c) * (1.0_pReal - zeta) - crystallite_converged(g,i,e) = all(abs(residuum_plastic(1:sizeDotState)) & - < max(plasticState(p)%aTolState(1:sizeDotState), & - abs(plasticState(p)%state(1:sizeDotState,c)*rTol_crystalliteState))) + crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizeDotState), & + plasticState(p)%state(1:sizeDotState,c), & + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) @@ -1659,9 +1655,9 @@ subroutine integrateStateFPI() + sourceState(p)%p(s)%previousDotState(:,c)* (1.0_pReal - zeta) crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and. & - all(abs(residuum_source(1:sizeDotState)) & - < max(sourceState(p)%p(s)%aTolState(1:sizeDotState), & - abs(sourceState(p)%p(s)%state(1:sizeDotState,c)*rTol_crystalliteState))) + converged(residuum_source(1:sizeDotState), & + sourceState(p)%p(s)%state(1:sizeDotState,c), & + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif enddo; enddo; enddo @@ -1729,6 +1725,23 @@ subroutine integrateStateFPI() endif end function damper + + !-------------------------------------------------------------------------------------------------- + !> @brief determines whether a point is converged + !-------------------------------------------------------------------------------------------------- + logical pure function converged(residuum,state,aTol) + use prec, only: & + dEq0 + use numerics, only: & + rTol => rTol_crystalliteState + + implicit none + real(pReal), intent(in), dimension(:) ::& + residuum, state, aTol + + converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) + + end function converged end subroutine integrateStateFPI @@ -1835,9 +1848,9 @@ subroutine integrateStateAdaptiveEuler() residuum_plastic(1:sizeDotState,g,i,e) = residuum_plastic(1:sizeDotState,g,i,e) & + 0.5_pReal * plasticState(p)%dotState(:,c) * crystallite_subdt(g,i,e) - crystallite_converged(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & + crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & plasticState(p)%state(1:sizeDotState,c), & - plasticState(p)%aTolState(1:sizeDotState))) + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState @@ -1846,9 +1859,9 @@ subroutine integrateStateAdaptiveEuler() + 0.5_pReal * sourceState(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e) crystallite_converged(g,i,e) = crystallite_converged(g,i,e) .and.& - all(converged(residuum_source(1:sizeDotState,s,g,i,e), & + converged(residuum_source(1:sizeDotState,s,g,i,e), & sourceState(p)%p(s)%state(1:sizeDotState,c), & - sourceState(p)%p(s)%aTolState(1:sizeDotState))) + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif @@ -1862,22 +1875,17 @@ subroutine integrateStateAdaptiveEuler() !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure elemental function converged(residuum,state,aTol) + logical pure function converged(residuum,state,aTol) use prec, only: & dEq0 use numerics, only: & rTol => rTol_crystalliteState implicit none - real(pReal), intent(in) ::& + real(pReal), intent(in), dimension(:) ::& residuum, state, aTol - if (dEq0(state)) then - converged = .true. ! ToDo: intended behavior? Not rely on absoluteTolerance - else - converged = abs(residuum) < aTol & - .or. abs(residuum/state) < rTol - endif + converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) end function converged @@ -2111,17 +2119,17 @@ subroutine integrateStateRKCK45() sizeDotState = plasticState(p)%sizeDotState - crystallite_todo(g,i,e) = all(converged(residuum_plastic(1:sizeDotState,g,i,e), & + crystallite_todo(g,i,e) = converged(residuum_plastic(1:sizeDotState,g,i,e), & plasticState(p)%state(1:sizeDotState,cc), & - plasticState(p)%aTolState(1:sizeDotState))) + plasticState(p)%aTolState(1:sizeDotState)) do s = 1_pInt, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and.& - all(converged(residuum_source(1:sizeDotState,s,g,i,e), & + converged(residuum_source(1:sizeDotState,s,g,i,e), & sourceState(p)%p(s)%state(1:sizeDotState,cc), & - sourceState(p)%p(s)%aTolState(1:sizeDotState))) + sourceState(p)%p(s)%aTolState(1:sizeDotState)) enddo endif enddo; enddo; enddo @@ -2138,22 +2146,17 @@ subroutine integrateStateRKCK45() !-------------------------------------------------------------------------------------------------- !> @brief determines whether a point is converged !-------------------------------------------------------------------------------------------------- - logical pure elemental function converged(residuum,state,aTol) + logical pure function converged(residuum,state,aTol) use prec, only: & dEq0 use numerics, only: & rTol => rTol_crystalliteState implicit none - real(pReal), intent(in) ::& + real(pReal), intent(in), dimension(:) ::& residuum, state, aTol - if (dEq0(state)) then - converged = .true. ! ToDo: intended behavior? Not rely on absoluteTolerance - else - converged = abs(residuum) < aTol & - .or. abs(residuum/state) < rTol - endif + converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) end function converged From aabd98bee9fe4d0a8eaec49bc545ebfe6f073b91 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 31 Jan 2019 09:14:02 +0100 Subject: [PATCH 354/372] no need to repeat the same code --- src/crystallite.f90 | 73 +++++++++++---------------------------------- 1 file changed, 18 insertions(+), 55 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index f9ceab03c..45aca46d1 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1725,23 +1725,6 @@ subroutine integrateStateFPI() endif end function damper - - !-------------------------------------------------------------------------------------------------- - !> @brief determines whether a point is converged - !-------------------------------------------------------------------------------------------------- - logical pure function converged(residuum,state,aTol) - use prec, only: & - dEq0 - use numerics, only: & - rTol => rTol_crystalliteState - - implicit none - real(pReal), intent(in), dimension(:) ::& - residuum, state, aTol - - converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) - - end function converged end subroutine integrateStateFPI @@ -1870,25 +1853,6 @@ subroutine integrateStateAdaptiveEuler() if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck - contains - - !-------------------------------------------------------------------------------------------------- - !> @brief determines whether a point is converged - !-------------------------------------------------------------------------------------------------- - logical pure function converged(residuum,state,aTol) - use prec, only: & - dEq0 - use numerics, only: & - rTol => rTol_crystalliteState - - implicit none - real(pReal), intent(in), dimension(:) ::& - residuum, state, aTol - - converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) - - end function converged - end subroutine integrateStateAdaptiveEuler @@ -2141,25 +2105,6 @@ subroutine integrateStateRKCK45() call setConvergenceFlag if (any(plasticState(:)%nonlocal)) call nonlocalConvergenceCheck - contains - - !-------------------------------------------------------------------------------------------------- - !> @brief determines whether a point is converged - !-------------------------------------------------------------------------------------------------- - logical pure function converged(residuum,state,aTol) - use prec, only: & - dEq0 - use numerics, only: & - rTol => rTol_crystalliteState - - implicit none - real(pReal), intent(in), dimension(:) ::& - residuum, state, aTol - - converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) - - end function converged - end subroutine integrateStateRKCK45 @@ -2201,6 +2146,24 @@ subroutine setConvergenceFlag() end subroutine setConvergenceFlag + !-------------------------------------------------------------------------------------------------- + !> @brief determines whether a point is converged + !-------------------------------------------------------------------------------------------------- + logical pure function converged(residuum,state,aTol) + use prec, only: & + dEq0 + use numerics, only: & + rTol => rTol_crystalliteState + + implicit none + real(pReal), intent(in), dimension(:) ::& + residuum, state, aTol + + converged = all(abs(residuum) <= max(aTol, rTol*abs(state))) + + end function converged + + !-------------------------------------------------------------------------------------------------- !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- From ccb320fa6ebd46cc2b8087457ce49eaa8adddd97 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 31 Jan 2019 14:00:26 +0100 Subject: [PATCH 355/372] central function for less depencies --- src/plastic_nonlocal.f90 | 48 +++++++++++++--------------------------- 1 file changed, 15 insertions(+), 33 deletions(-) diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index c43de6627..417800629 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -216,8 +216,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_init(fileUnit) use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) -use math, only: math_Mandel3333to66, & - math_Voigt66to3333, & +use math, only: math_Voigt66to3333, & math_mul3x3, & math_transpose33 use IO, only: IO_read, & @@ -245,11 +244,11 @@ use material, only: phase_plasticity, & PLASTICITY_NONLOCAL_label, & PLASTICITY_NONLOCAL_ID, & plasticState, & - material_phase + material_phase, & + material_allocatePlasticState use config, only: MATERIAL_partPhase use lattice -use numerics,only: & - numerics_integrator + implicit none @@ -929,30 +928,13 @@ allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), endif enddo outputsLoop - plasticState(phase)%sizeState = sizeState - plasticState(phase)%sizeDotState = sizeDotState - plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_nonlocal_sizePostResults(instance) plasticState(phase)%nonlocal = .true. - plasticState(phase)%nSlip = totalNslip(instance) - plasticState(phase)%nTwin = 0_pInt - plasticState(phase)%nTrans= 0_pInt - allocate(plasticState(phase)%aTolState (sizeState), source=0.0_pReal) - allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) + call material_allocatePlasticState(phase,NofMyPhase,sizeState,sizeDotState,sizeDeltaState, & + totalNslip(instance),0_pInt,0_pInt) - allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + plasticState(phase)%slipRate => & plasticState(phase)%dotState(iGamma(1,instance):iGamma(ns,instance),1:NofMyPhase) plasticState(phase)%accumulatedSlip => & @@ -1638,10 +1620,10 @@ end subroutine plastic_nonlocal_kinetics !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dTstar99, Tstar_v, Temperature, ip, el) -use math, only: math_Plain3333to99, & +use math, only: math_3333to99, & math_mul6x6, & math_mul33xx33, & - math_Mandel6to33 + math_6toSym33 use debug, only: debug_level, & debug_constitutive, & debug_levelExtensive, & @@ -1733,11 +1715,11 @@ do s = 1_pInt,ns tauNS(s,1) = tau(s) tauNS(s,2) = tau(s) if (tau(s) > 0.0_pReal) then - tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,1,s,instance)) - tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,3,s,instance)) + tauNS(s,3) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,1,s,instance)) + tauNS(s,4) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,3,s,instance)) else - tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,2,s,instance)) - tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,4,s,instance)) + tauNS(s,3) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,2,s,instance)) + tauNS(s,4) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,4,s,instance)) endif enddo forall (t = 1_pInt:4_pInt) & @@ -1812,7 +1794,7 @@ do s = 1_pInt,ns * burgers(s,instance) endif enddo -dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) +dLp_dTstar99 = math_3333to99(dLp_dTstar3333) #ifdef DEBUG From d33c7a28030375b488a48f538a452d44682bafda Mon Sep 17 00:00:00 2001 From: Test User Date: Thu, 31 Jan 2019 14:24:28 +0100 Subject: [PATCH 356/372] [skip ci] updated version information after successful test of v2.0.2-1667-g6b66563b --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index cd40c2f04..2479c4238 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1634-g370b23d5 +v2.0.2-1667-g6b66563b From 721af0a9a9ad75c8789ad6fe1f5ce256d7a93704 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 1 Feb 2019 07:06:19 +0100 Subject: [PATCH 357/372] plastic_nonlocal still has confusing state handling --- src/plastic_nonlocal.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 417800629..cba989cb5 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -933,7 +933,8 @@ allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), plasticState(phase)%nonlocal = .true. call material_allocatePlasticState(phase,NofMyPhase,sizeState,sizeDotState,sizeDeltaState, & totalNslip(instance),0_pInt,0_pInt) - + + plasticState(phase)%offsetDeltaState = 0_pInt plasticState(phase)%slipRate => & plasticState(phase)%dotState(iGamma(1,instance):iGamma(ns,instance),1:NofMyPhase) From d13b0f11648deb9430b61f7d57493f3b51510ce7 Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 2 Feb 2019 08:54:10 +0100 Subject: [PATCH 358/372] [skip ci] updated version information after successful test of v2.0.2-1674-g683dee82 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 2479c4238..543d23432 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1667-g6b66563b +v2.0.2-1674-g683dee82 From 36662f84192ec8a6131b6d09d6d582c2326d8f98 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 05:38:24 +0100 Subject: [PATCH 359/372] more generic formulation (works for all dimensions) --- src/HDF5_utilities.f90 | 446 ++++++++++++++++++++--------------------- 1 file changed, 223 insertions(+), 223 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 2a05f101c..2a302d6ed 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -459,20 +459,20 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -482,8 +482,8 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(1) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) @@ -492,8 +492,9 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -517,7 +518,7 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') !-------------------------------------------------------------------------------------------------- @@ -554,20 +555,20 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -577,18 +578,19 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(2) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal2: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -649,20 +651,20 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -672,18 +674,19 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(3) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal3: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -744,20 +747,20 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -767,18 +770,19 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(4) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal4: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -839,20 +843,20 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -862,18 +866,19 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(5) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal5: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -934,20 +939,20 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -957,18 +962,19 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(6) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal6: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -1029,20 +1035,20 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties @@ -1052,18 +1058,19 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(7) + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal7: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- @@ -1124,43 +1131,42 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(1) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1221,43 +1227,42 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(2) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1318,43 +1323,42 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(3) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1415,43 +1419,42 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(4) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1512,43 +1515,42 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(5) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1609,43 +1611,42 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(6) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) @@ -1706,43 +1707,42 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!-------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(7) - + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') endif; endif #endif - - myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(readSize)] + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) From c668260c37bfeb0407c85bff3a47d5e284651d44 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 08:05:29 +0100 Subject: [PATCH 360/372] avoiding code duplication --- src/HDF5_utilities.f90 | 1030 ++++++++++------------------------------ 1 file changed, 259 insertions(+), 771 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 2a302d6ed..39cca9502 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -449,9 +449,6 @@ end subroutine HDF5_setLink !> @brief subroutine for reading dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:) :: dataset @@ -459,9 +456,7 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -469,65 +464,28 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- !close types, dataspaces call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') @@ -545,9 +503,6 @@ end subroutine HDF5_read_pReal1 !> @brief subroutine for reading dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:) :: dataset @@ -555,9 +510,7 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -565,59 +518,22 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -641,9 +557,6 @@ end subroutine HDF5_read_pReal2 !> @brief subroutine for reading dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:) :: dataset @@ -651,9 +564,7 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -661,59 +572,22 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -737,9 +611,6 @@ end subroutine HDF5_read_pReal3 !> @brief subroutine for reading dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:) :: dataset @@ -747,9 +618,7 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -757,59 +626,22 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -833,9 +665,6 @@ end subroutine HDF5_read_pReal4 !> @brief subroutine for reading dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -843,9 +672,7 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -853,59 +680,22 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -929,9 +719,6 @@ end subroutine HDF5_read_pReal5 !> @brief subroutine for reading dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -939,9 +726,7 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -949,59 +734,22 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1025,9 +773,6 @@ end subroutine HDF5_read_pReal6 !> @brief subroutine for reading dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -1035,9 +780,7 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1045,59 +788,22 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1121,9 +827,6 @@ end subroutine HDF5_read_pReal7 !> @brief subroutine for reading dataset of type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:) :: dataset @@ -1131,9 +834,7 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1141,59 +842,22 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1217,9 +881,6 @@ end subroutine HDF5_read_pInt1 !> @brief subroutine for reading dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:) :: dataset @@ -1227,9 +888,7 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1237,59 +896,22 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1313,9 +935,6 @@ end subroutine HDF5_read_pInt2 !> @brief subroutine for reading dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:) :: dataset @@ -1323,9 +942,7 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1333,59 +950,22 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1409,9 +989,6 @@ end subroutine HDF5_read_pInt3 !> @brief subroutine for reading dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset @@ -1419,9 +996,7 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1429,59 +1004,22 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1505,9 +1043,6 @@ end subroutine HDF5_read_pInt4 !> @brief subroutine for reading dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -1515,9 +1050,7 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1525,59 +1058,22 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1601,9 +1097,6 @@ end subroutine HDF5_read_pInt5 !> @brief subroutine for reading dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -1611,9 +1104,7 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1621,59 +1112,22 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -1697,9 +1151,6 @@ end subroutine HDF5_read_pInt6 !> @brief subroutine for reading dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -1707,9 +1158,7 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - integer(pInt), dimension(worldsize) :: & - readSize !< contribution of all processes - integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & @@ -1717,59 +1166,22 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return ! ToDo: Correct? Seems to result in a deadlock for MPI if my processor has nothing to read + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) @@ -3050,6 +2462,82 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_pInt7 +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for reading dataset of type pReal with 1 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), intent(in), dimension(:) :: & + localShape + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myStart, & + globalShape !< shape of the dataset (all processes) + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) +!-------------------------------------------------------------------------------------------------- + readSize = 0_pInt + readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) +#ifdef PETSc + if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') + endif +#endif + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] + + +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & + int(localShape,HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') +!-------------------------------------------------------------------------------------------------- +! set I/O mode for read operations to collective + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! get the space_id of dataset in the file + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') + + +end subroutine initialize_read + end module HDF5_Utilities From d934f2b141cf97c1935ff8ae2861b74280bdcd2c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 09:01:37 +0100 Subject: [PATCH 361/372] also modularize write --- src/HDF5_utilities.f90 | 531 +++++++++++++---------------------------- 1 file changed, 172 insertions(+), 359 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 39cca9502..d7b56a697 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -1204,9 +1204,6 @@ end subroutine HDF5_read_pInt7 !> @brief subroutine for writing dataset of type pReal with 1 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:) :: dataset @@ -1215,61 +1212,27 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(1) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') - endif; endif -#endif - - myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1295,9 +1258,6 @@ end subroutine HDF5_write_pReal1 !> @brief subroutine for writing dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:) :: dataset @@ -1306,61 +1266,27 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(2) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal2: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1386,9 +1312,6 @@ end subroutine HDF5_write_pReal2 !> @brief subroutine for writing dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:) :: dataset @@ -1397,61 +1320,27 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(3) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal3: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1477,9 +1366,6 @@ end subroutine HDF5_write_pReal3 !> @brief subroutine for writing dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:) :: dataset @@ -1488,61 +1374,27 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(4) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal4: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1568,9 +1420,6 @@ end subroutine HDF5_write_pReal4 !> @brief subroutine for writing dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -1579,61 +1428,27 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(5) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal5: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1659,9 +1474,6 @@ end subroutine HDF5_write_pReal5 !> @brief subroutine for writing dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -1670,61 +1482,27 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(6) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal6: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1750,9 +1528,6 @@ end subroutine HDF5_write_pReal6 !> @brief subroutine for writing dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -1761,61 +1536,27 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) + localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)) == 0)) return -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(7) - -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal7: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sselect_hyperslab_f') +if (present(parallel)) then +call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -2513,8 +2254,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) + call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! set I/O mode for read operations to collective @@ -2538,6 +2278,79 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ end subroutine initialize_read + +!-------------------------------------------------------------------------------------------------- +!> @brief subroutine for writing dataset of type pReal with 1 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,parallel) + use numerics, only: & + worldrank, & + worldsize + + implicit none + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + + integer(HSIZE_T), intent(in), dimension(:) :: & + localShape + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myStart, & + globalShape !< shape of the dataset (all processes) + integer(pInt), dimension(worldsize) :: & + outputSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + +!-------------------------------------------------------------------------------------------------- + outputSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) + +#ifdef PETSc +if (parallel) then + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') + endif +#endif + + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(outputSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(outputSize),HSIZE_T)] + + +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dopen_f') + +!-------------------------------------------------------------------------------------------------- +! create dataspace in file (global shape) + call h5screate_simple_f(size(globalShape), globalShape, filespace_id, hdferr, globalShape) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! create dataset + call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') +!-------------------------------------------------------------------------------------------------- +! select a hyperslab (the portion of the current process) in the file + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') + + +end subroutine initialize_write + + end module HDF5_Utilities From 73749dd7887f58ae734ec930664ffce5eda322ce Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 09:38:49 +0100 Subject: [PATCH 362/372] merged also finalization --- src/HDF5_utilities.f90 | 1047 +++++++++++++--------------------------- 1 file changed, 342 insertions(+), 705 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index d7b56a697..ee5128e20 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -18,7 +18,7 @@ module HDF5_utilities HDF5_ERR_TYPE = 4_pInt !< kind of the integer return in the HDF5 library !-------------------------------------------------------------------------------------------------- -!> @brief reads pInt or pReal data of defined shape from file +!> @brief reads pInt or pReal data of defined shape from file ! ToDo: order of arguments wrong !-------------------------------------------------------------------------------------------------- interface HDF5_read module procedure HDF5_read_pReal1 @@ -40,7 +40,7 @@ module HDF5_utilities end interface HDF5_read !-------------------------------------------------------------------------------------------------- -!> @brief writes pInt or pReal data of defined shape to file +!> @brief writes pInt or pReal data of defined shape to file ! ToDo: order of arguments wrong !-------------------------------------------------------------------------------------------------- interface HDF5_write module procedure HDF5_write_pReal1 @@ -446,163 +446,138 @@ subroutine HDF5_setLink(loc_id,target_name,link_name) end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 1 dimensions +!> @brief subroutine for reading dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:) :: dataset + real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') !--------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') - +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + end subroutine HDF5_read_pReal1 - !-------------------------------------------------------------------------------------------------- !> @brief subroutine for reading dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:) :: dataset + real(pReal), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal2 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 3 dimensions +!> @brief subroutine for reading dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal3 @@ -613,50 +588,42 @@ end subroutine HDF5_read_pReal3 subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal4 @@ -667,50 +634,42 @@ end subroutine HDF5_read_pReal4 subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal5 @@ -721,50 +680,42 @@ end subroutine HDF5_read_pReal5 subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal6 @@ -775,105 +726,85 @@ end subroutine HDF5_read_pReal6 subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') +!--------------------------------------------------------------------------------------------------- +! finalize HDF5 data structures + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 1 dimensions +!> @brief subroutine for reading dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:) :: dataset + integer(pInt), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt1 @@ -883,51 +814,39 @@ end subroutine HDF5_read_pInt1 subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt2 @@ -937,51 +856,39 @@ end subroutine HDF5_read_pInt2 subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt3 @@ -991,51 +898,39 @@ end subroutine HDF5_read_pInt3 subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt4 @@ -1045,51 +940,39 @@ end subroutine HDF5_read_pInt4 subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt5 @@ -1099,51 +982,39 @@ end subroutine HDF5_read_pInt5 subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt6 @@ -1153,51 +1024,39 @@ end subroutine HDF5_read_pInt6 subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel - - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + myStart, globalShape, loc_id,localShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) + myStart, globalShape, loc_id,localShape,datasetName,.false.) endif !--------------------------------------------------------------------------------------------------- ! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/memspace_id') - end subroutine HDF5_read_pInt7 !-------------------------------------------------------------------------------------------------- @@ -1219,20 +1078,20 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1273,20 +1132,20 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1327,20 +1186,20 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1381,20 +1240,20 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1435,20 +1294,20 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1489,20 +1348,20 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1543,20 +1402,20 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) localShape, & !< shape of the dataset (this process) globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)) == 0)) return + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -if (present(parallel)) then -call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1584,9 +1443,6 @@ end subroutine HDF5_write_pReal7 !> @brief subroutine for writing dataset of type pInt with 1 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:) :: dataset @@ -1595,59 +1451,27 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(1) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') - endif; endif -#endif - myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1673,9 +1497,6 @@ end subroutine HDF5_write_pInt1 !> @brief subroutine for writing dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:) :: dataset @@ -1684,59 +1505,27 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(2) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') - endif; endif -#endif - myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1762,9 +1551,6 @@ end subroutine HDF5_write_pInt2 !> @brief subroutine for writing dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:) :: dataset @@ -1773,59 +1559,27 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(3) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1851,9 +1605,6 @@ end subroutine HDF5_write_pInt3 !> @brief subroutine for writing dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset @@ -1862,59 +1613,27 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(4) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -1940,9 +1659,6 @@ end subroutine HDF5_write_pInt4 !> @brief subroutine for writing dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -1951,59 +1667,27 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(5) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -2029,9 +1713,6 @@ end subroutine HDF5_write_pInt5 !> @brief subroutine for writing dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -2040,59 +1721,27 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(6) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -2118,9 +1767,6 @@ end subroutine HDF5_write_pInt6 !> @brief subroutine for writing dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -2129,59 +1775,27 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(7) -#ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dcreate_f') -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sselect_hyperslab_f') + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif !-------------------------------------------------------------------------------------------------- ! write @@ -2204,7 +1818,7 @@ end subroutine HDF5_write_pInt7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 1 dimensions +!> @brief !-------------------------------------------------------------------------------------------------- subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & myStart, globalShape, & @@ -2280,11 +1894,33 @@ end subroutine initialize_read !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 1 dimensions +!> @brief +!-------------------------------------------------------------------------------------------------- +subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + + implicit none + integer(HDF5_ERR_TYPE) :: hdferr + integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + +!--------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') + +end subroutine finalize_read + +!-------------------------------------------------------------------------------------------------- +!> @brief !-------------------------------------------------------------------------------------------------- subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & myStart, globalShape, & - loc_id,localShape,datasetName,parallel) + loc_id,localShape,datasetName,datatype,parallel) use numerics, only: & worldrank, & worldsize @@ -2302,6 +1938,7 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & globalShape !< shape of the dataset (all processes) integer(pInt), dimension(worldsize) :: & outputSize !< contribution of all processes +integer(HSIZE_T), intent(in) :: datatype integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id @@ -2340,7 +1977,7 @@ if (parallel) then !-------------------------------------------------------------------------------------------------- ! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) + call h5dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file From 5d9c3fcf273d69042ac3cd1ec48cd6214d9ca2d7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 09:44:41 +0100 Subject: [PATCH 363/372] finalize for write --- src/HDF5_utilities.f90 | 47 ++++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index ee5128e20..2b902c1c8 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -19,6 +19,7 @@ module HDF5_utilities !-------------------------------------------------------------------------------------------------- !> @brief reads pInt or pReal data of defined shape from file ! ToDo: order of arguments wrong +!> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_read module procedure HDF5_read_pReal1 @@ -41,6 +42,7 @@ module HDF5_utilities !-------------------------------------------------------------------------------------------------- !> @brief writes pInt or pReal data of defined shape to file ! ToDo: order of arguments wrong +!> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_write module procedure HDF5_write_pReal1 @@ -1059,8 +1061,9 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) end subroutine HDF5_read_pInt7 + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 1 dimensions +!> @brief subroutine for writing dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) @@ -1436,11 +1439,8 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_pReal7 - - - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 1 dimensions +!> @brief subroutine for writing dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) @@ -1988,19 +1988,26 @@ if (parallel) then end subroutine initialize_write +!-------------------------------------------------------------------------------------------------- +!> @brief +!-------------------------------------------------------------------------------------------------- +subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) + + implicit none + integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id + integer(HDF5_ERR_TYPE) :: hdferr + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/memspace_id') + +end subroutine finalize_write + end module HDF5_Utilities - - - - - - - - - - - - - - - From 8167f09ec6f82d699b39b37ffdbb4d387a9ac25f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 11:45:02 +0100 Subject: [PATCH 364/372] using functions as far as possible --- src/HDF5_utilities.f90 | 496 +++++++++++------------------------------ 1 file changed, 128 insertions(+), 368 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 2b902c1c8..da6bd4979 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -447,8 +447,9 @@ subroutine HDF5_setLink(loc_id,target_name,link_name) end subroutine HDF5_setLink + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 1 dimension +!> @brief read dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) @@ -480,20 +481,16 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal1 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 2 dimensions +!> @brief read dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) @@ -525,21 +522,16 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 2 dimensions +!> @brief read dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) @@ -570,22 +562,17 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & myStart, globalShape, loc_id,localShape,datasetName,.false.) endif - -!--------------------------------------------------------------------------------------------------- -! read + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 4 dimensions +!> @brief read dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) @@ -617,21 +604,16 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 5 dimensions +!> @brief read dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) @@ -663,21 +645,16 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 6 dimensions +!> @brief read dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) @@ -709,21 +686,16 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 7 dimensions +!> @brief read dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) @@ -755,21 +727,17 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') -!--------------------------------------------------------------------------------------------------- -! finalize HDF5 data structures - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 1 dimension +!> @brief read dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) @@ -801,17 +769,16 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + end subroutine HDF5_read_pInt1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 2 dimensions +!> @brief read dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) @@ -843,17 +810,16 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 3 dimensions +!> @brief read dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) @@ -885,17 +851,16 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 4 dimensions +!> @brief read dataset of type pInt withh 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) @@ -927,17 +892,16 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 5 dimensions +!> @brief read dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) @@ -969,17 +933,16 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 6 dimensions +!> @brief read dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) @@ -1011,17 +974,16 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 7 dimensions +!> @brief read dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) @@ -1053,17 +1015,17 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) myStart, globalShape, loc_id,localShape,datasetName,.false.) endif -!--------------------------------------------------------------------------------------------------- -! read call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 1 dimension +!> @brief write dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) @@ -1088,36 +1050,22 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 2 dimensions +!> @brief write dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) @@ -1142,36 +1090,22 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 3 dimensions +!> @brief write dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) @@ -1196,36 +1130,22 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 4 dimensions +!> @brief write dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) @@ -1250,36 +1170,23 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal4 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 5 dimensions +!> @brief write dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) @@ -1304,36 +1211,22 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 6 dimensions +!> @brief write dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) @@ -1358,36 +1251,22 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 7 dimensions +!> @brief write dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) @@ -1412,35 +1291,23 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal7 + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 1 dimension +!> @brief write dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) @@ -1465,36 +1332,22 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 2 dimensions +!> @brief write dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) @@ -1519,36 +1372,22 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 3 dimensions +!> @brief write dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) @@ -1573,36 +1412,22 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 4 dimensions +!> @brief write dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) @@ -1627,36 +1452,22 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 5 dimensions +!> @brief write dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) @@ -1681,36 +1492,22 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 6 dimensions +!> @brief write dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) @@ -1735,36 +1532,22 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 7 dimensions +!> @brief write dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) @@ -1789,36 +1572,23 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif -!-------------------------------------------------------------------------------------------------- -! write call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt7 !-------------------------------------------------------------------------------------------------- -!> @brief +!> @brief initialize HDF5 handles, determines global shape and start for parallel read !-------------------------------------------------------------------------------------------------- subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & myStart, globalShape, & @@ -1844,57 +1614,53 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ globalShape !< shape of the dataset (all processes) !------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties +! creating a property list for transfer properties (is collective for MPI) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) !-------------------------------------------------------------------------------------------------- readSize = 0_pInt readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pReal1: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_read: MPI_allreduce') endif #endif myStart = int(0,HSIZE_T) myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] - !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file +! creating a property list for IO and set it to collective + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file and get the space ID + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dopen_f') call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dget_space_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') - + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5sselect_hyperslab_f') end subroutine initialize_read !-------------------------------------------------------------------------------------------------- -!> @brief +!> @brief closes HDF5 handles !-------------------------------------------------------------------------------------------------- subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1902,21 +1668,20 @@ subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id -!--------------------------------------------------------------------------------------------------- -!close types, dataspaces call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/memspace_id') end subroutine finalize_read + !-------------------------------------------------------------------------------------------------- -!> @brief +!> @brief initialize HDF5 handles, determines global shape and start for parallel write !-------------------------------------------------------------------------------------------------- subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & myStart, globalShape, & @@ -1938,7 +1703,7 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & globalShape !< shape of the dataset (all processes) integer(pInt), dimension(worldsize) :: & outputSize !< contribution of all processes -integer(HSIZE_T), intent(in) :: datatype + integer(HID_T), intent(in) :: datatype integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id @@ -1954,9 +1719,9 @@ integer(HSIZE_T), intent(in) :: datatype #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_write_pReal1: MPI_allreduce') + if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_write: MPI_allreduce') endif #endif @@ -1966,30 +1731,27 @@ if (parallel) then !-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) +! create dataspace in memory (local shape) and in file (global shape) call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dopen_f') call h5screate_simple_f(size(globalShape), globalShape, filespace_id, hdferr, globalShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset call h5dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dcreate_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dcreate_f') + !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') - + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5sselect_hyperslab_f') end subroutine initialize_write !-------------------------------------------------------------------------------------------------- -!> @brief +!> @brief closes HDF5 handles !-------------------------------------------------------------------------------------------------- subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1997,8 +1759,6 @@ subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id integer(HDF5_ERR_TYPE) :: hdferr -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: plist_id') call h5dclose_f(dset_id, hdferr) From de26e41684a49669ec68eb4ac16ed923b656450b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 15:02:07 +0000 Subject: [PATCH 365/372] some first steps to support debugging with the PGI compiler norm2 and sum for initialization are not supported yet, need fixes --- CMakeLists.txt | 27 +++++++++++++++++++++++++++ src/compilation_info.f90 | 6 +++++- src/math.f90 | 18 ++++++++++++++++++ 3 files changed, 50 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 3aa49cd7a..6096c8824 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -445,6 +445,33 @@ elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") # Additional options # -fdefault-integer-8: Use it to set precision to 8 bytes for integer, don't use it for the standard case of pInt=4 (there is no -fdefault-integer-4) + + +################################################################################################### +# PGI Compiler +################################################################################################### +elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0" ) + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-O3") + endif () + + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Mpreprocess") + # preprocessor + + set (STANDARD_CHECK "-Mallocatable=03") + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Includes debugging information in the object module; sets the optimization level to zero unless a -⁠O option is present on the command line else () message (FATAL_ERROR "Compiler type (CMAKE_Fortran_COMPILER_ID) not recognized") endif () diff --git a/src/compilation_info.f90 b/src/compilation_info.f90 index f0ca4d4cc..77d181a38 100644 --- a/src/compilation_info.f90 +++ b/src/compilation_info.f90 @@ -1,9 +1,13 @@ +! https://github.com/jeffhammond/HPCInfo/blob/master/docs/Preprocessor-Macros.md #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 write(6,*) 'Compiled with ', compiler_version() write(6,*) 'With options ', compiler_options() -#else +#elif defined(__INTEL_COMPILER) write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version ', __INTEL_COMPILER,& ', build date ', __INTEL_COMPILER_BUILD_DATE +#elif defined(__PGI) + write(6,'(a,i4.4,a,i8.8)') ' Compiled with PGI fortran version ', __PGIC__,& + '.', __PGIC_MINOR__ #endif write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ write(6,*) diff --git a/src/math.f90 b/src/math.f90 index 28c7175e3..4d7736b31 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -118,6 +118,9 @@ module math !--------------------------------------------------------------------------------------------------- public :: & +#if defined(__PGI) + norm2, & +#endif math_init, & math_qsort, & math_expand, & @@ -2707,4 +2710,19 @@ 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 when using PGI 18.10 +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function norm2(v) + + implicit none + real(pReal), intent(in), dimension(3) :: v + + norm2 = sqrt(sum(a**2)) + +end function norm2 +#endif + end module math From 09859f1b12157b3580ef9014dfae8599d3e92089 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 16:53:05 +0100 Subject: [PATCH 366/372] wrong variable rename (was forgotten) --- src/math.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/math.f90 b/src/math.f90 index 4d7736b31..644063d66 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -2720,7 +2720,7 @@ real(pReal) pure function norm2(v) implicit none real(pReal), intent(in), dimension(3) :: v - norm2 = sqrt(sum(a**2)) + norm2 = sqrt(sum(v**2)) end function norm2 #endif From c4eef520fcb7dd796fa092b72298e7a944be2ace Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 17:21:11 +0100 Subject: [PATCH 367/372] initialize all variables --- src/HDF5_utilities.f90 | 60 +++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index da6bd4979..0582318ce 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -1291,10 +1291,10 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& @@ -1598,24 +1598,25 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ worldsize implicit none - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in) :: parallel + integer(HSIZE_T), intent(in), dimension(:) :: & + localShape + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myStart, & + globalShape !< shape of the dataset (all processes) + integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(pInt), dimension(worldsize) :: & readSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), intent(in), dimension(:) :: & - localShape - integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & - myStart, & - globalShape !< shape of the dataset (all processes) - + !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties (is collective for MPI) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') !-------------------------------------------------------------------------------------------------- readSize = 0_pInt @@ -1665,8 +1666,8 @@ end subroutine initialize_read subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) implicit none - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HDF5_ERR_TYPE) :: hdferr call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_id') @@ -1691,44 +1692,43 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & worldsize implicit none - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - - integer(HSIZE_T), intent(in), dimension(:) :: & + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in) :: parallel + integer(HID_T), intent(in) :: datatype + integer(HSIZE_T), intent(in), dimension(:) :: & localShape - integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & myStart, & globalShape !< shape of the dataset (all processes) + integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id + integer(pInt), dimension(worldsize) :: & - outputSize !< contribution of all processes - integer(HID_T), intent(in) :: datatype + writeSize !< contribution of all processes integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pcreate_f') !-------------------------------------------------------------------------------------------------- - outputSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) + writeSize = 0_pInt + writeSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_write: MPI_allreduce') endif #endif myStart = int(0,HSIZE_T) - myStart(ubound(myStart)) = int(sum(outputSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(outputSize),HSIZE_T)] - + myStart(ubound(myStart)) = int(sum(writeSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(writeSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) and in file (global shape) From af28e9cdd9ed2e959cb43e3d1df2163ba9a65f28 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 9 Feb 2019 17:23:56 +0100 Subject: [PATCH 368/372] not needed anymore --- src/FEM_utilities.f90 | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/FEM_utilities.f90 b/src/FEM_utilities.f90 index 1db950e63..fd6e90206 100644 --- a/src/FEM_utilities.f90 +++ b/src/FEM_utilities.f90 @@ -162,7 +162,6 @@ subroutine utilities_init() character(len=1024) :: petsc_optionsPhysics integer(pInt) :: dimPlex - integer(pInt) :: headerID = 205_pInt PetscInt, allocatable :: nEntities(:), nOutputCells(:), nOutputNodes(:) PetscInt :: dim PetscErrorCode :: ierr @@ -213,13 +212,6 @@ subroutine utilities_init() nOutputCells(worldrank+1) = count(material_homog > 0_pInt) call MPI_Allreduce(MPI_IN_PLACE,nOutputNodes,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) call MPI_Allreduce(MPI_IN_PLACE,nOutputCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) - if (worldrank == 0_pInt) then - open(unit=headerID, file=trim(getSolverJobName())//'.header', & - form='FORMATTED', status='REPLACE') - write(headerID, '(a,i0)') 'dimension : ', dimPlex - write(headerID, '(a,i0)') 'number of nodes : ', sum(nOutputNodes) - write(headerID, '(a,i0)') 'number of cells : ', sum(nOutputCells) - endif end subroutine utilities_init From 87f3e3f62114bd083f20d92de688f363a6071794 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 11 Feb 2019 10:08:34 +0100 Subject: [PATCH 369/372] more flexible and user friendly --- src/math.f90 | 79 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 47 insertions(+), 32 deletions(-) diff --git a/src/math.f90 b/src/math.f90 index 644063d66..e663103c8 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -119,7 +119,7 @@ module math public :: & #if defined(__PGI) - norm2, & + norm2, & #endif math_init, & math_qsort, & @@ -354,20 +354,38 @@ end subroutine math_check !-------------------------------------------------------------------------------------------------- !> @brief Quicksort algorithm for two-dimensional integer arrays -! Sorting is done with respect to array(1,:) -! and keeps array(2:N,:) linked to it. +! Sorting is done with respect to array(sort,:) and keeps array(/=sort,:) linked to it. +! default: sort=1 !-------------------------------------------------------------------------------------------------- -recursive subroutine math_qsort(a, istart, iend) +recursive subroutine math_qsort(a, istart, iend, sortDim) implicit none integer(pInt), dimension(:,:), intent(inout) :: a - integer(pInt), intent(in) :: istart,iend - integer(pInt) :: ipivot - - if (istart < iend) then - ipivot = qsort_partition(a,istart, iend) - call math_qsort(a, istart, ipivot-1_pInt) - call math_qsort(a, ipivot+1_pInt, iend) + integer(pInt), intent(in),optional :: istart,iend, sortDim + integer(pInt) :: ipivot,s,e,d + + if(present(istart)) then + s = istart + else + s = lbound(a,2) + endif + + if(present(iend)) then + e = iend + else + e = ubound(a,2) + endif + + if(present(sortDim)) then + d = sortDim + else + d = 1 + endif + + if (s < e) then + ipivot = qsort_partition(a,s, e, d) + call math_qsort(a, s, ipivot-1_pInt, d) + call math_qsort(a, ipivot+1_pInt, e, d) endif !-------------------------------------------------------------------------------------------------- @@ -376,37 +394,34 @@ recursive subroutine math_qsort(a, istart, iend) !------------------------------------------------------------------------------------------------- !> @brief Partitioning required for quicksort !------------------------------------------------------------------------------------------------- - integer(pInt) function qsort_partition(a, istart, iend) + integer(pInt) function qsort_partition(a, istart, iend, sort) implicit none integer(pInt), dimension(:,:), intent(inout) :: a - integer(pInt), intent(in) :: istart,iend - integer(pInt) :: i,j,k,tmp + integer(pInt), intent(in) :: istart,iend,sort + integer(pInt), dimension(size(a,1)) :: tmp + integer(pInt) :: i,j do - ! find the first element on the right side less than or equal to the pivot point + ! find the first element on the right side less than or equal to the pivot point do j = iend, istart, -1_pInt - if (a(1,j) <= a(1,istart)) exit + if (a(sort,j) <= a(sort,istart)) exit enddo - ! find the first element on the left side greater than the pivot point + ! find the first element on the left side greater than the pivot point do i = istart, iend - if (a(1,i) > a(1,istart)) exit + if (a(sort,i) > a(sort,istart)) exit enddo - if (i < j) then ! if the indexes do not cross, exchange values - do k = 1_pInt, int(size(a,1_pInt), pInt) - tmp = a(k,i) - a(k,i) = a(k,j) - a(k,j) = tmp - enddo - else ! if they do cross, exchange left value with pivot and return with the partition index - do k = 1_pInt, int(size(a,1_pInt), pInt) - tmp = a(k,istart) - a(k,istart) = a(k,j) - a(k,j) = tmp - enddo + cross: if (i >= j) then ! if the indices cross, exchange left value with pivot and return with the partition index + tmp = a(:,istart) + a(:,istart) = a(:,j) + a(:,j) = tmp qsort_partition = j return - endif + else cross ! if they do not cross, exchange values + tmp = a(:,i) + a(:,i) = a(:,j) + a(:,j) = tmp + endif cross enddo end function qsort_partition @@ -2713,7 +2728,7 @@ end function math_clip #if defined(__PGI) !-------------------------------------------------------------------------------------------------- -!> @brief substitute for the norm2 intrinsic which is not available when using PGI 18.10 +!> @brief substitute for the norm2 intrinsic which is not available in PGI 18.10 !-------------------------------------------------------------------------------------------------- real(pReal) pure function norm2(v) From b0c20beefa3c899e810aa22f3f14db8efa28cde2 Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 11 Feb 2019 15:11:31 +0100 Subject: [PATCH 370/372] [skip ci] updated version information after successful test of v2.0.2-1687-gfa1c946d --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 543d23432..f8fbcdee0 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1674-g683dee82 +v2.0.2-1687-gfa1c946d From 1a471bcd8a3f2d50e13d9e403442bc8923cb06f4 Mon Sep 17 00:00:00 2001 From: Arko Jyoti Bhattacharjee Date: Mon, 11 Feb 2019 18:46:14 +0100 Subject: [PATCH 371/372] signal handling implemented allows to trigger action in running simulation, i.e. writing restart or results --- src/C_routines.c | 10 +++ src/DAMASK_interface.f90 | 44 +++++++++++- src/system_routines.f90 | 148 +++++++++++++++++++-------------------- 3 files changed, 125 insertions(+), 77 deletions(-) diff --git a/src/C_routines.c b/src/C_routines.c index e3891765a..3dccb7644 100644 --- a/src/C_routines.c +++ b/src/C_routines.c @@ -6,9 +6,11 @@ #include #include #include +#include /* http://stackoverflow.com/questions/30279228/is-there-an-alternative-to-getcwd-in-fortran-2003-2008 */ + int isdirectory_c(const char *dir){ struct stat statbuf; if(stat(dir, &statbuf) != 0) /* error */ @@ -44,3 +46,11 @@ void gethostname_c(char hostname[], int *stat){ int chdir_c(const char *dir){ return chdir(dir); } + +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 a2b4f53f2..7a8e77f62 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -12,9 +12,9 @@ module DAMASK_interface use prec, only: & pInt - implicit none private + logical, public, protected :: SIGUSR1,SIGUSR2 integer(pInt), public, protected :: & interface_restartInc = 0_pInt !< Increment at which calculation starts character(len=1024), public, protected :: & @@ -42,6 +42,8 @@ contains subroutine DAMASK_interface_init() use, intrinsic :: & iso_fortran_env + use :: & + iso_c_binding #include #if defined(__GFORTRAN__) && __GNUC__ < 5 =================================================================================================== @@ -81,6 +83,8 @@ subroutine DAMASK_interface_init() use PETScSys use system_routines, only: & + signalusr1_C, & + signalusr2_C, & getHostName, & getCWD @@ -229,6 +233,12 @@ subroutine DAMASK_interface_init() if (interface_restartInc > 0_pInt) & 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. + + end subroutine DAMASK_interface_init @@ -412,6 +422,35 @@ character(len=1024) function makeRelativePath(a,b) end function makeRelativePath +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR1 to .true. if program receives SIGUSR1 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR1(signal) bind(C) + use :: iso_c_binding + + implicit none + integer(C_INT), value :: signal + SIGUSR1 = .true. + + write(6,*) 'received signal ',signal, 'set SIGUSR1' + +end subroutine setSIGUSR1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR2 to .true. if program receives SIGUSR2 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR2(signal) bind(C) + use :: iso_c_binding + + implicit none + integer(C_INT), value :: signal + SIGUSR2 = .true. + + write(6,*) 'received signal ',signal, 'set SIGUSR2' + +end subroutine setSIGUSR2 + !-------------------------------------------------------------------------------------------------- !> @brief taken from IO, check IO_stringValue for documentation @@ -469,11 +508,10 @@ pure function IIO_stringPos(string) do while (verify(string(right+1:),SEP)>0) left = right + verify(string(right+1:),SEP) right = left + scan(string(left:),SEP) - 2 - if ( string(left:left) == '#' ) exit IIO_stringPos = [IIO_stringPos,int(left, pInt), int(right, pInt)] IIO_stringPos(1) = IIO_stringPos(1)+1_pInt enddo end function IIO_stringPos -end module +end module \ No newline at end of file diff --git a/src/system_routines.f90 b/src/system_routines.f90 index bea777a3d..27f0cae34 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -3,11 +3,17 @@ !> @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 public :: & + signalusr1_C, & + signalusr2_C, & isDirectory, & getCWD, & getHostName, & @@ -27,7 +33,7 @@ interface use, intrinsic :: ISO_C_Binding, only: & C_INT, & C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array integer(C_INT),intent(out) :: stat end subroutine getCurrentWorkDir_C @@ -35,7 +41,7 @@ interface use, intrinsic :: ISO_C_Binding, only: & C_INT, & C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array integer(C_INT),intent(out) :: stat end subroutine getHostName_C @@ -46,31 +52,38 @@ interface integer(C_INT) :: chdir_C character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array end function chdir_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 - contains !-------------------------------------------------------------------------------------------------- !> @brief figures out if a given path is a directory (and not an ordinary file) !-------------------------------------------------------------------------------------------------- logical function isDirectory(path) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR - implicit none - character(len=*), intent(in) :: path - character(kind=C_CHAR), dimension(1024) :: strFixedLength - integer :: i + implicit none + character(len=*), intent(in) :: path + character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string as array + integer :: i - strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) - do i=1,len(path) ! copy array components - strFixedLength(i)=path(i:i) - enddo - isDirectory=merge(.True.,.False.,isDirectory_C(strFixedLength) /= 0_C_INT) + strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) + do i=1,len(path) ! copy array components + strFixedLength(i)=path(i:i) + enddo + isDirectory=merge(.True.,.False.,isDirectory_C(strFixedLength) /= 0_C_INT) end function isDirectory @@ -79,29 +92,25 @@ end function isDirectory !> @brief gets the current working directory !-------------------------------------------------------------------------------------------------- character(len=1024) function getCWD() - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR - implicit none - character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array - integer(C_INT) :: stat - integer :: i + implicit none + character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array + integer(C_INT) :: stat + integer :: i - call getCurrentWorkDir_C(charArray,stat) - if (stat /= 0_C_INT) then - getCWD = 'Error occured when getting currend working directory' - else - getCWD = repeat('',len(getCWD)) - arrayToString: do i=1,len(getCWD) - if (charArray(i) /= C_NULL_CHAR) then - getCWD(i:i)=charArray(i) - else - exit - endif - enddo arrayToString - endif + call getCurrentWorkDir_C(charArray,stat) + if (stat /= 0_C_INT) then + getCWD = 'Error occured when getting currend working directory' + else + getCWD = repeat('',len(getCWD)) + arrayToString: do i=1,len(getCWD) + if (charArray(i) /= C_NULL_CHAR) then + getCWD(i:i)=charArray(i) + else + exit + endif + enddo arrayToString + endif end function getCWD @@ -110,51 +119,42 @@ end function getCWD !> @brief gets the current host name !-------------------------------------------------------------------------------------------------- character(len=1024) function getHostName() - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR + implicit none + character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array + integer(C_INT) :: stat + integer :: i - implicit none - character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array - integer(C_INT) :: stat - integer :: i - - call getHostName_C(charArray,stat) - if (stat /= 0_C_INT) then - getHostName = 'Error occured when getting host name' - else - getHostName = repeat('',len(getHostName)) - arrayToString: do i=1,len(getHostName) - if (charArray(i) /= C_NULL_CHAR) then - getHostName(i:i)=charArray(i) - else - exit - endif - enddo arrayToString - endif + call getHostName_C(charArray,stat) + if (stat /= 0_C_INT) then + getHostName = 'Error occured when getting host name' + else + getHostName = repeat('',len(getHostName)) + arrayToString: do i=1,len(getHostName) + if (charArray(i) /= C_NULL_CHAR) then + getHostName(i:i)=charArray(i) + else + exit + endif + enddo arrayToString + endif end function getHostName + !-------------------------------------------------------------------------------------------------- !> @brief changes the current working directory !-------------------------------------------------------------------------------------------------- logical function setCWD(path) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR + implicit none + character(len=*), intent(in) :: path + character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string is an array + integer :: i - implicit none - character(len=*), intent(in) :: path - character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string is an array - integer :: i - - strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) - do i=1,len(path) ! copy array components - strFixedLength(i)=path(i:i) - enddo - setCWD=merge(.True.,.False.,chdir_C(strFixedLength) /= 0_C_INT) + strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) + do i=1,len(path) ! copy array components + strFixedLength(i)=path(i:i) + enddo + setCWD=merge(.True.,.False.,chdir_C(strFixedLength) /= 0_C_INT) end function setCWD From 79b7ae1b3ef94a744089d226be8670775b39deb1 Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 12 Feb 2019 01:12:16 +0100 Subject: [PATCH 372/372] [skip ci] updated version information after successful test of v2.0.2-1689-g1a471bcd --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index f8fbcdee0..6e1ce244f 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1687-gfa1c946d +v2.0.2-1689-g1a471bcd