From d0b832e6f184c178f126a2d91178a5f735d8d62b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 3 Jun 2023 17:06:32 +0200 Subject: [PATCH 1/7] consistent with naming in HDF5_utilities --- src/HDF5_utilities.f90 | 2 +- src/IO.f90 | 40 +++--- src/Marc/discretization_Marc.f90 | 8 +- src/YAML_types.f90 | 136 +++++++++--------- src/grid/DAMASK_grid.f90 | 8 +- src/grid/VTI.f90 | 4 +- src/grid/grid_damage_spectral.f90 | 6 +- src/grid/grid_mech_FEM.f90 | 12 +- src/grid/grid_mech_spectral_basic.f90 | 14 +- src/grid/grid_mech_spectral_polarisation.f90 | 22 +-- src/grid/grid_thermal_spectral.f90 | 6 +- src/grid/spectral_utilities.f90 | 2 +- src/homogenization_mechanical_RGC.f90 | 34 ++--- src/material.f90 | 6 +- src/mesh/DAMASK_mesh.f90 | 4 +- src/mesh/FEM_quadrature.f90 | 6 +- src/mesh/mesh_mech_FEM.f90 | 4 +- src/misc.f90 | 6 +- src/phase.f90 | 26 ++-- src/phase_damage.f90 | 4 +- src/phase_damage_anisobrittle.f90 | 10 +- src/phase_damage_isobrittle.f90 | 4 +- ...phase_mechanical_plastic_dislotungsten.f90 | 44 +++--- src/phase_mechanical_plastic_dislotwin.f90 | 88 ++++++------ src/phase_mechanical_plastic_isotropic.f90 | 28 ++-- ...phase_mechanical_plastic_kinehardening.f90 | 28 ++-- src/phase_mechanical_plastic_nonlocal.f90 | 76 +++++----- ...phase_mechanical_plastic_phenopowerlaw.f90 | 54 +++---- src/phase_thermal.f90 | 6 +- src/phase_thermal_dissipation.f90 | 2 +- src/polynomials.f90 | 10 +- src/prec.f90 | 14 +- src/tables.f90 | 2 +- 33 files changed, 358 insertions(+), 358 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 936b224e8..c6af2facb 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -28,7 +28,7 @@ module HDF5_utilities private !-------------------------------------------------------------------------------------------------- -!> @brief Read integer or float data of defined shape from file. +!> @brief Read integer or real data of defined shape from file. !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_read diff --git a/src/IO.f90 b/src/IO.f90 index 882b7faf6..315bc9fb5 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -35,12 +35,12 @@ module IO IO_stringPos, & IO_stringValue, & IO_intValue, & - IO_floatValue, & + IO_realValue, & IO_lc, & IO_rmComment, & IO_intAsString, & IO_stringAsInt, & - IO_stringAsFloat, & + IO_stringAsReal, & IO_stringAsBool, & IO_error, & IO_warning, & @@ -272,17 +272,17 @@ end function IO_intValue !-------------------------------------------------------------------------------------------------- -!> @brief Read float value at myChunk from string. +!> @brief Read real value at myChunk from string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_floatValue(string,chunkPos,myChunk) +real(pReal) function IO_realValue(string,chunkPos,myChunk) character(len=*), intent(in) :: string !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk - IO_floatValue = IO_stringAsFloat(IO_stringValue(string,chunkPos,myChunk)) + IO_realValue = IO_stringAsReal(IO_stringValue(string,chunkPos,myChunk)) -end function IO_floatValue +end function IO_realValue !-------------------------------------------------------------------------------------------------- @@ -371,25 +371,25 @@ end function IO_stringAsInt !-------------------------------------------------------------------------------------------------- -!> @brief Return float value from given string. +!> @brief Return real value from given string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_stringAsFloat(string) +real(pReal) function IO_stringAsReal(string) - character(len=*), intent(in) :: string !< string for conversion to float value + character(len=*), intent(in) :: string !< string for conversion to real value integer :: readStatus character(len=*), parameter :: VALIDCHARS = '0123456789eE.+- ' valid: if (verify(string,VALIDCHARS) == 0) then - read(string,*,iostat=readStatus) IO_stringAsFloat + read(string,*,iostat=readStatus) IO_stringAsReal if (readStatus /= 0) call IO_error(112,string) else valid - IO_stringAsFloat = 0.0_pReal + IO_stringAsReal = 0.0_pReal call IO_error(112,string) end if valid -end function IO_stringAsFloat +end function IO_stringAsReal !-------------------------------------------------------------------------------------------------- @@ -441,7 +441,7 @@ subroutine IO_error(error_ID,ext_msg,label1,ID1,label2,ID2) case (111) msg = 'invalid character for int:' case (112) - msg = 'invalid character for float:' + msg = 'invalid character for real:' case (113) msg = 'invalid character for logical:' case (114) @@ -733,12 +733,12 @@ subroutine selfTest() character(len=:), allocatable :: str,out - if (dNeq(1.0_pReal, IO_stringAsFloat('1.0'))) error stop 'IO_stringAsFloat' - if (dNeq(1.0_pReal, IO_stringAsFloat('1e0'))) error stop 'IO_stringAsFloat' - if (dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) error stop 'IO_stringAsFloat' - if (dNeq(0.1_pReal, IO_stringAsFloat('1.0e-1'))) error stop 'IO_stringAsFloat' - if (dNeq(0.1_pReal, IO_stringAsFloat('1.00e-1'))) error stop 'IO_stringAsFloat' - if (dNeq(10._pReal, IO_stringAsFloat(' 1.0e+1 '))) error stop 'IO_stringAsFloat' + if (dNeq(1.0_pReal, IO_stringAsReal('1.0'))) error stop 'IO_stringAsReal' + if (dNeq(1.0_pReal, IO_stringAsReal('1e0'))) error stop 'IO_stringAsReal' + if (dNeq(0.1_pReal, IO_stringAsReal('1e-1'))) error stop 'IO_stringAsReal' + if (dNeq(0.1_pReal, IO_stringAsReal('1.0e-1'))) error stop 'IO_stringAsReal' + if (dNeq(0.1_pReal, IO_stringAsReal('1.00e-1'))) error stop 'IO_stringAsReal' + if (dNeq(10._pReal, IO_stringAsReal(' 1.0e+1 '))) error stop 'IO_stringAsReal' if (3112019 /= IO_stringAsInt( '3112019')) error stop 'IO_stringAsInt' if (3112019 /= IO_stringAsInt(' 3112019')) error stop 'IO_stringAsInt' @@ -760,7 +760,7 @@ subroutine selfTest() str = ' 1.0 xxx' chunkPos = IO_stringPos(str) - if (dNeq(1.0_pReal,IO_floatValue(str,chunkPos,1))) error stop 'IO_floatValue' + if (dNeq(1.0_pReal,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue' str = 'M 3112019 F' chunkPos = IO_stringPos(str) diff --git a/src/Marc/discretization_Marc.f90 b/src/Marc/discretization_Marc.f90 index 46e9eba45..cdc7863ca 100644 --- a/src/Marc/discretization_Marc.f90 +++ b/src/Marc/discretization_Marc.f90 @@ -75,7 +75,7 @@ subroutine discretization_Marc_init print'(/,a)', ' <<<+- discretization_Marc init -+>>>'; flush(6) num_commercialFEM => config_numerics%get_dict('commercialFEM',defaultVal = emptyDict) - mesh_unitlength = num_commercialFEM%get_asFloat('unitlength',defaultVal=1.0_pReal) ! set physical extent of a length unit in mesh + mesh_unitlength = num_commercialFEM%get_asReal('unitlength',defaultVal=1.0_pReal) ! set physical extent of a length unit in mesh if (mesh_unitlength <= 0.0_pReal) call IO_error(301,'unitlength') call inputRead(elem,node0_elem,connectivity_elem,materialAt) @@ -552,7 +552,7 @@ subroutine inputRead_elemNodes(nodes, & chunkPos = [4,1,10,11,30,31,50,51,70] do i=1,nNode m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1)) - nodes(1:3,m) = [(mesh_unitlength * IO_floatValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)] + nodes(1:3,m) = [(mesh_unitlength * IO_realValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)] end do exit end if @@ -735,8 +735,8 @@ subroutine inputRead_material(materialAt,& if (sv == 2) then ! state var 2 gives material ID m = 1 chunkPos = IO_stringPos(fileContent(l+k+m)) - do while (scan(IO_stringValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is noEfloat value? - ID = nint(IO_floatValue(fileContent(l+k+m),chunkPos,1)) + do while (scan(IO_stringValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is no Efloat value? + ID = nint(IO_realValue(fileContent(l+k+m),chunkPos,1)) if (initialcondTableStyle == 2) m = m + 2 contInts = continuousIntValues(fileContent(l+k+m+1:),nElem,nameElemSet,mapElemSet,size(nameElemSet)) ! get affected elements do i = 1,contInts(1) diff --git a/src/YAML_types.f90 b/src/YAML_types.f90 index a6ac9766d..201dd1da0 100644 --- a/src/YAML_types.f90 +++ b/src/YAML_types.f90 @@ -32,10 +32,10 @@ module YAML_types contains procedure :: & asFormattedString => tScalar_asFormattedString, & - asFloat => tScalar_asFloat, & - asInt => tScalar_asInt, & - asBool => tScalar_asBool, & - asString => tScalar_asString + asReal => tScalar_asReal, & + asInt => tScalar_asInt, & + asBool => tScalar_asBool, & + asString => tScalar_asString end type tScalar type, extends(tNode), public :: tList @@ -46,8 +46,8 @@ module YAML_types procedure :: & asFormattedString => tList_asFormattedString, & append => tList_append, & - as1dFloat => tList_as1dFloat, & - as2dFloat => tList_as2dFloat, & + as1dReal => tList_as1dReal, & + as2dReal => tList_as2dReal, & as1dInt => tList_as1dInt, & as1dBool => tList_as1dBool, & as1dString => tList_as1dString, & @@ -56,8 +56,8 @@ module YAML_types tList_get_scalar, & tList_get_list, & tList_get_dict, & - tList_get_asFloat, & - tList_get_as1dFloat, & + tList_get_asReal, & + tList_get_as1dReal, & tList_get_asInt, & tList_get_as1dInt, & tList_get_asBool, & @@ -68,8 +68,8 @@ module YAML_types generic :: get_scalar => tList_get_scalar generic :: get_list => tList_get_list generic :: get_dict => tList_get_dict - generic :: get_asFloat => tList_get_asFloat - generic :: get_as1dFloat => tList_get_as1dFloat + generic :: get_asReal => tList_get_asReal + generic :: get_as1dReal => tList_get_as1dReal generic :: get_asInt => tList_get_asInt generic :: get_as1dInt => tList_get_as1dInt generic :: get_asBool => tList_get_asBool @@ -92,9 +92,9 @@ module YAML_types tDict_get_scalar, & tDict_get_list, & tDict_get_dict, & - tDict_get_asFloat, & - tDict_get_as1dFloat, & - tDict_get_as2dFloat, & + tDict_get_asReal, & + tDict_get_as1dReal, & + tDict_get_as2dReal, & tDict_get_asInt, & tDict_get_as1dInt, & tDict_get_asBool, & @@ -105,9 +105,9 @@ module YAML_types generic :: get_scalar => tDict_get_scalar generic :: get_list => tDict_get_list generic :: get_dict => tDict_get_dict - generic :: get_asFloat => tDict_get_asFloat - generic :: get_as1dFloat => tDict_get_as1dFloat - generic :: get_as2dFloat => tDict_get_as2dFloat + generic :: get_asReal => tDict_get_asReal + generic :: get_as1dReal => tDict_get_as1dReal + generic :: get_as2dReal => tDict_get_as2dReal generic :: get_asInt => tDict_get_asInt generic :: get_as1dInt => tDict_get_as1dInt generic :: get_asBool => tDict_get_asBool @@ -183,7 +183,7 @@ subroutine selfTest() s = '1' if (s%asInt() /= 1) error stop 'tScalar_asInt' if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)' - if (dNeq(s%asFloat(),1.0_pReal)) error stop 'tScalar_asFloat' + if (dNeq(s%asReal(),1.0_pReal)) error stop 'tScalar_asReal' s = 'true' if (.not. s%asBool()) error stop 'tScalar_asBool' if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)' @@ -209,11 +209,11 @@ subroutine selfTest() call l%append(s1) call l%append(s2) if (l%length /= 2) error stop 'tList%len' - if (dNeq(l%get_asFloat(1),1.0_pReal)) error stop 'tList_get_asFloat' + if (dNeq(l%get_asReal(1),1.0_pReal)) error stop 'tList_get_asReal' if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt' if (l%get_asString(2) /= '2') error stop 'tList_get_asString' if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt' - if (any(dNeq(l%as1dFloat(),real([1.0,2.0],pReal)))) error stop 'tList_as1dFloat' + if (any(dNeq(l%as1dReal(),real([1.0,2.0],pReal)))) error stop 'tList_as1dReal' s1 = 'true' s2 = 'false' if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool' @@ -253,7 +253,7 @@ subroutine selfTest() if (d%asFormattedString() /= '{one-two: [1, 2], three: 3, four: 4}') & error stop 'tDict_asFormattedString' if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt' - if (dNeq(d%get_asFloat('three'),3.0_pReal)) error stop 'tDict_get_asFloat' + if (dNeq(d%get_asReal('three'),3.0_pReal)) error stop 'tDict_get_asReal' if (d%get_asString('three') /= '3') error stop 'tDict_get_asString' if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt' call d%set('one-two',s4) @@ -371,17 +371,17 @@ end function tNode_asDict !-------------------------------------------------------------------------------------------------- -!> @brief Convert to float. +!> @brief Convert to real. !-------------------------------------------------------------------------------------------------- -function tScalar_asFloat(self) +function tScalar_asReal(self) class(tScalar), intent(in), target :: self - real(pReal) :: tScalar_asFloat + real(pReal) :: tScalar_asReal - tScalar_asFloat = IO_stringAsFloat(self%value) + tScalar_asReal = IO_stringAsReal(self%value) -end function tScalar_asFloat +end function tScalar_asReal !-------------------------------------------------------------------------------------------------- @@ -476,51 +476,51 @@ end subroutine tList_append !-------------------------------------------------------------------------------------------------- -!> @brief Convert to float array (1D). +!> @brief Convert to real array (1D). !-------------------------------------------------------------------------------------------------- -function tList_as1dFloat(self) +function tList_as1dReal(self) class(tList), intent(in), target :: self - real(pReal), dimension(:), allocatable :: tList_as1dFloat + real(pReal), dimension(:), allocatable :: tList_as1dReal integer :: i type(tItem), pointer :: item type(tScalar), pointer :: scalar - allocate(tList_as1dFloat(self%length)) + allocate(tList_as1dReal(self%length)) item => self%first do i = 1, self%length scalar => item%node%asScalar() - tList_as1dFloat(i) = scalar%asFloat() + tList_as1dReal(i) = scalar%asReal() item => item%next end do -end function tList_as1dFloat +end function tList_as1dReal !-------------------------------------------------------------------------------------------------- -!> @brief Convert to float array (2D). +!> @brief Convert to real array (2D). !-------------------------------------------------------------------------------------------------- -function tList_as2dFloat(self) +function tList_as2dReal(self) class(tList), intent(in), target :: self - real(pReal), dimension(:,:), allocatable :: tList_as2dFloat + real(pReal), dimension(:,:), allocatable :: tList_as2dReal integer :: i type(tList), pointer :: row_data row_data => self%get_list(1) - allocate(tList_as2dFloat(self%length,row_data%length)) + allocate(tList_as2dReal(self%length,row_data%length)) do i = 1, self%length row_data => self%get_list(i) - if (row_data%length /= size(tList_as2dFloat,2)) call IO_error(709,ext_msg='inconsistent column count in tList_as2dFloat') - tList_as2dFloat(i,:) = self%get_as1dFloat(i) + if (row_data%length /= size(tList_as2dReal,2)) call IO_error(709,ext_msg='inconsistent column count in tList_as2dReal') + tList_as2dReal(i,:) = self%get_as1dReal(i) end do -end function tList_as2dFloat +end function tList_as2dReal !-------------------------------------------------------------------------------------------------- @@ -718,39 +718,39 @@ end function tList_get_dict !-------------------------------------------------------------------------------------------------- -!> @brief Get scalar by index and convert to float. +!> @brief Get scalar by index and convert to real. !-------------------------------------------------------------------------------------------------- -function tList_get_asFloat(self,i) result(nodeAsFloat) +function tList_get_asReal(self,i) result(nodeAsReal) class(tList), intent(in) :: self integer, intent(in) :: i - real(pReal) :: nodeAsFloat + real(pReal) :: nodeAsReal class(tScalar), pointer :: scalar scalar => self%get_scalar(i) - nodeAsFloat = scalar%asFloat() + nodeAsReal = scalar%asReal() -end function tList_get_asFloat +end function tList_get_asReal !-------------------------------------------------------------------------------------------------- -!> @brief Get list by index and convert to float array (1D). +!> @brief Get list by index and convert to real array (1D). !-------------------------------------------------------------------------------------------------- -function tList_get_as1dFloat(self,i) result(nodeAs1dFloat) +function tList_get_as1dReal(self,i) result(nodeAs1dReal) class(tList), intent(in) :: self integer, intent(in) :: i - real(pReal), dimension(:), allocatable :: nodeAs1dFloat + real(pReal), dimension(:), allocatable :: nodeAs1dReal class(tList), pointer :: list list => self%get_list(i) - nodeAs1dFloat = list%as1dFloat() + nodeAs1dReal = list%as1dReal() -end function tList_get_as1dFloat +end function tList_get_as1dReal !-------------------------------------------------------------------------------------------------- @@ -1118,88 +1118,88 @@ end function tDict_get_dict !-------------------------------------------------------------------------------------------------- -!> @brief Get scalar by key and convert to float. +!> @brief Get scalar by key and convert to real. !-------------------------------------------------------------------------------------------------- -function tDict_get_asFloat(self,k,defaultVal) result(nodeAsFloat) +function tDict_get_asReal(self,k,defaultVal) result(nodeAsReal) class(tDict), intent(in) :: self character(len=*), intent(in) :: k real(pReal), intent(in), optional :: defaultVal - real(pReal) :: nodeAsFloat + real(pReal) :: nodeAsReal type(tScalar), pointer :: scalar if (self%contains(k)) then scalar => self%get_scalar(k) - nodeAsFloat = scalar%asFloat() + nodeAsReal = scalar%asReal() elseif (present(defaultVal)) then - nodeAsFloat = defaultVal + nodeAsReal = defaultVal else call IO_error(143,ext_msg=k) end if -end function tDict_get_asFloat +end function tDict_get_asReal !-------------------------------------------------------------------------------------------------- -!> @brief Get list by key and convert to float array (1D). +!> @brief Get list by key and convert to real array (1D). !-------------------------------------------------------------------------------------------------- -function tDict_get_as1dFloat(self,k,defaultVal,requiredSize) result(nodeAs1dFloat) +function tDict_get_as1dReal(self,k,defaultVal,requiredSize) result(nodeAs1dReal) class(tDict), intent(in) :: self character(len=*), intent(in) :: k real(pReal), intent(in), dimension(:), optional :: defaultVal integer, intent(in), optional :: requiredSize - real(pReal), dimension(:), allocatable :: nodeAs1dFloat + real(pReal), dimension(:), allocatable :: nodeAs1dReal type(tList), pointer :: list if (self%contains(k)) then list => self%get_list(k) - nodeAs1dFloat = list%as1dFloat() + nodeAs1dReal = list%as1dReal() elseif (present(defaultVal)) then - nodeAs1dFloat = defaultVal + nodeAs1dReal = defaultVal else call IO_error(143,ext_msg=k) end if if (present(requiredSize)) then - if (requiredSize /= size(nodeAs1dFloat)) call IO_error(146,ext_msg=k) + if (requiredSize /= size(nodeAs1dReal)) call IO_error(146,ext_msg=k) end if -end function tDict_get_as1dFloat +end function tDict_get_as1dReal !-------------------------------------------------------------------------------------------------- -!> @brief Get list of lists by key and convert to float array (2D). +!> @brief Get list of lists by key and convert to real array (2D). !-------------------------------------------------------------------------------------------------- -function tDict_get_as2dFloat(self,k,defaultVal,requiredShape) result(nodeAs2dFloat) +function tDict_get_as2dReal(self,k,defaultVal,requiredShape) result(nodeAs2dReal) class(tDict), intent(in) :: self character(len=*), intent(in) :: k real(pReal), intent(in), dimension(:,:), optional :: defaultVal integer, intent(in), dimension(2), optional :: requiredShape - real(pReal), dimension(:,:), allocatable :: nodeAs2dFloat + real(pReal), dimension(:,:), allocatable :: nodeAs2dReal type(tList), pointer :: list if (self%contains(k)) then list => self%get_list(k) - nodeAs2dFloat = list%as2dFloat() + nodeAs2dReal = list%as2dReal() elseif (present(defaultVal)) then - nodeAs2dFloat = defaultVal + nodeAs2dReal = defaultVal else call IO_error(143,ext_msg=k) end if if (present(requiredShape)) then - if (any(requiredShape /= shape(nodeAs2dFloat))) call IO_error(146,ext_msg=k) + if (any(requiredShape /= shape(nodeAs2dReal))) call IO_error(146,ext_msg=k) end if -end function tDict_get_as2dFloat +end function tDict_get_as2dReal !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 index c77832346..84cd94e45 100644 --- a/src/grid/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -234,14 +234,14 @@ program DAMASK_grid call getMaskedTensor(loadCases(l)%stress%values,loadCases(l)%stress%mask,step_mech%get_list(m)) #endif end select - call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dFloat('R',defaultVal = real([0.0,0.0,1.0,0.0],pReal)),degrees=.true.) + call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dReal('R',defaultVal = real([0.0,0.0,1.0,0.0],pReal)),degrees=.true.) end do readMech if (.not. allocated(loadCases(l)%deformation%myType)) call IO_error(error_ID=837,ext_msg = 'L/dot_F/F missing') step_discretization => load_step%get_dict('discretization') - loadCases(l)%t = step_discretization%get_asFloat('t') + loadCases(l)%t = step_discretization%get_asReal('t') loadCases(l)%N = step_discretization%get_asInt ('N') - loadCases(l)%r = step_discretization%get_asFloat('r',defaultVal= 1.0_pReal) + loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pReal) loadCases(l)%f_restart = load_step%get_asInt('f_restart', defaultVal=huge(0)) if (load_step%get_asString('f_out',defaultVal='n/a') == 'none') then @@ -526,7 +526,7 @@ subroutine getMaskedTensor(values,mask,tensor) row => tensor%get_list(i) do j = 1,3 mask(i,j) = row%get_asString(j) == 'x' - if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j) + if (.not. mask(i,j)) values(i,j) = row%get_asReal(j) end do end do diff --git a/src/grid/VTI.f90 b/src/grid/VTI.f90 index cc5a6843b..ebc162ca9 100644 --- a/src/grid/VTI.f90 +++ b/src/grid/VTI.f90 @@ -216,11 +216,11 @@ subroutine cellsSizeOrigin(c,s,o,header) c = [(IO_intValue(temp,IO_stringPos(temp),i),i=2,6,2)] temp = getXMLValue(header,'Spacing') - delta = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)] + delta = [(IO_realValue(temp,IO_stringPos(temp),i),i=1,3)] s = delta * real(c,pReal) temp = getXMLValue(header,'Origin') - o = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)] + o = [(IO_realValue(temp,IO_stringPos(temp),i),i=1,3)] end subroutine cellsSizeOrigin diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index 0ba3c5a31..2c5ac0f16 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -98,11 +98,11 @@ subroutine grid_damage_spectral_init() ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) - num%eps_damage_atol = num_grid%get_asFloat ('eps_damage_atol',defaultVal=1.0e-2_pReal) - num%eps_damage_rtol = num_grid%get_asFloat ('eps_damage_rtol',defaultVal=1.0e-6_pReal) + num%eps_damage_atol = num_grid%get_asReal ('eps_damage_atol',defaultVal=1.0e-2_pReal) + num%eps_damage_rtol = num_grid%get_asReal ('eps_damage_rtol',defaultVal=1.0e-6_pReal) num_generic => config_numerics%get_dict('generic',defaultVal=emptyDict) - num%phi_min = num_generic%get_asFloat('phi_min', defaultVal=1.0e-6_pReal) + num%phi_min = num_generic%get_asReal('phi_min', defaultVal=1.0e-6_pReal) if (num%phi_min < 0.0_pReal) call IO_error(301,ext_msg='phi_min') if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index d55f58152..366504caa 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -129,12 +129,12 @@ subroutine grid_mechanical_FEM_init ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) - num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_pReal) - num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) - num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) + num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' diff --git a/src/grid/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 index f2a009afb..6c423d51a 100644 --- a/src/grid/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -131,13 +131,13 @@ subroutine grid_mechanical_spectral_basic_init() ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) - num%update_gamma = num_grid%get_asBool ('update_gamma', defaultVal=.false.) - num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_pReal) - num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) - num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) + num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) + num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 index 7bdd84d25..0b086508f 100644 --- a/src/grid/grid_mech_spectral_polarisation.f90 +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -142,17 +142,17 @@ subroutine grid_mechanical_spectral_polarisation_init() ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) - num%update_gamma = num_grid%get_asBool ('update_gamma', defaultVal=.false.) - num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_curl_atol = num_grid%get_asFloat('eps_curl_atol', defaultVal=1.0e-10_pReal) - num%eps_curl_rtol = num_grid%get_asFloat('eps_curl_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_pReal) - num%itmin = num_grid%get_asInt ('itmin', defaultVal=1) - num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) - num%alpha = num_grid%get_asFloat('alpha', defaultVal=1.0_pReal) - num%beta = num_grid%get_asFloat('beta', defaultVal=1.0_pReal) + num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) + num%eps_curl_atol = num_grid%get_asReal('eps_curl_atol', defaultVal=1.0e-10_pReal) + num%eps_curl_rtol = num_grid%get_asReal('eps_curl_rtol', defaultVal=5.0e-4_pReal) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%itmin = num_grid%get_asInt ('itmin', defaultVal=1) + num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) + num%alpha = num_grid%get_asReal('alpha', defaultVal=1.0_pReal) + num%beta = num_grid%get_asReal('beta', defaultVal=1.0_pReal) if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index 6483c91c6..e79a5d49e 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -92,9 +92,9 @@ subroutine grid_thermal_spectral_init() !------------------------------------------------------------------------------------------------- ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) - num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) - num%eps_thermal_atol = num_grid%get_asFloat ('eps_thermal_atol',defaultVal=1.0e-2_pReal) - num%eps_thermal_rtol = num_grid%get_asFloat ('eps_thermal_rtol',defaultVal=1.0e-6_pReal) + num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) + num%eps_thermal_atol = num_grid%get_asReal('eps_thermal_atol',defaultVal=1.0e-2_pReal) + num%eps_thermal_rtol = num_grid%get_asReal('eps_thermal_rtol',defaultVal=1.0e-6_pReal) if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') if (num%eps_thermal_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_thermal_atol') diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index 5821bd3c0..3a4b4c092 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -226,7 +226,7 @@ subroutine spectral_utilities_init() !-------------------------------------------------------------------------------------------------- ! general initialization of FFTW (see manual on fftw.org for more details) if (pReal /= C_DOUBLE .or. kind(1) /= C_INT) error stop 'C and Fortran datatypes do not match' - call fftw_set_timelimit(num_grid%get_asFloat('fftw_timelimit',defaultVal=300.0_pReal)) + call fftw_set_timelimit(num_grid%get_asReal('fftw_timelimit',defaultVal=300.0_pReal)) print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT) diff --git a/src/homogenization_mechanical_RGC.f90 b/src/homogenization_mechanical_RGC.f90 index 0e85fcca6..eff8a400e 100644 --- a/src/homogenization_mechanical_RGC.f90 +++ b/src/homogenization_mechanical_RGC.f90 @@ -108,19 +108,19 @@ module subroutine RGC_init() num_mechanical => num_homogenization%get_dict('mechanical',defaultVal=emptyDict) num_RGC => num_mechanical%get_dict('RGC',defaultVal=emptyDict) - num%atol = num_RGC%get_asFloat('atol', defaultVal=1.0e+4_pReal) - num%rtol = num_RGC%get_asFloat('rtol', defaultVal=1.0e-3_pReal) - num%absMax = num_RGC%get_asFloat('amax', defaultVal=1.0e+10_pReal) - num%relMax = num_RGC%get_asFloat('rmax', defaultVal=1.0e+2_pReal) - num%pPert = num_RGC%get_asFloat('perturbpenalty', defaultVal=1.0e-7_pReal) - num%xSmoo = num_RGC%get_asFloat('relvantmismatch', defaultVal=1.0e-5_pReal) - num%viscPower = num_RGC%get_asFloat('viscositypower', defaultVal=1.0e+0_pReal) - num%viscModus = num_RGC%get_asFloat('viscositymodulus', defaultVal=0.0e+0_pReal) - num%refRelaxRate = num_RGC%get_asFloat('refrelaxationrate', defaultVal=1.0e-3_pReal) - num%maxdRelax = num_RGC%get_asFloat('maxrelaxationrate', defaultVal=1.0e+0_pReal) - num%maxVolDiscr = num_RGC%get_asFloat('maxvoldiscrepancy', defaultVal=1.0e-5_pReal) - num%volDiscrMod = num_RGC%get_asFloat('voldiscrepancymod', defaultVal=1.0e+12_pReal) - num%volDiscrPow = num_RGC%get_asFloat('dicrepancypower', defaultVal=5.0_pReal) + num%atol = num_RGC%get_asReal('atol', defaultVal=1.0e+4_pReal) + num%rtol = num_RGC%get_asReal('rtol', defaultVal=1.0e-3_pReal) + num%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_pReal) + num%relMax = num_RGC%get_asReal('rmax', defaultVal=1.0e+2_pReal) + num%pPert = num_RGC%get_asReal('perturbpenalty', defaultVal=1.0e-7_pReal) + num%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_pReal) + num%viscPower = num_RGC%get_asReal('viscositypower', defaultVal=1.0e+0_pReal) + num%viscModus = num_RGC%get_asReal('viscositymodulus', defaultVal=0.0e+0_pReal) + num%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_pReal) + num%maxdRelax = num_RGC%get_asReal('maxrelaxationrate', defaultVal=1.0e+0_pReal) + num%maxVolDiscr = num_RGC%get_asReal('maxvoldiscrepancy', defaultVal=1.0e-5_pReal) + num%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_pReal) + num%volDiscrPow = num_RGC%get_asReal('dicrepancypower', defaultVal=5.0_pReal) if (num%atol <= 0.0_pReal) call IO_error(301,ext_msg='absTol_RGC') if (num%rtol <= 0.0_pReal) call IO_error(301,ext_msg='relTol_RGC') @@ -156,11 +156,11 @@ module subroutine RGC_init() if (homogenization_Nconstituents(ho) /= product(prm%N_constituents)) & call IO_error(211,ext_msg='N_constituents (RGC)') - prm%xi_alpha = homogMech%get_asFloat('xi_alpha') - prm%c_alpha = homogMech%get_asFloat('c_alpha') + prm%xi_alpha = homogMech%get_asReal('xi_alpha') + prm%c_alpha = homogMech%get_asReal('c_alpha') - prm%D_alpha = homogMech%get_as1dFloat('D_alpha', requiredSize=3) - prm%a_g = homogMech%get_as1dFloat('a_g', requiredSize=3) + prm%D_alpha = homogMech%get_as1dReal('D_alpha', requiredSize=3) + prm%a_g = homogMech%get_as1dReal('a_g', requiredSize=3) Nmembers = count(material_ID_homogenization == ho) nIntFaceTot = 3*( (prm%N_constituents(1)-1)*prm%N_constituents(2)*prm%N_constituents(3) & diff --git a/src/material.f90 b/src/material.f90 index 2169c876a..a2e2a90aa 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -149,11 +149,11 @@ subroutine parse() do co = 1, constituents%length constituent => constituents%get_dict(co) - v_of(ma,co) = constituent%get_asFloat('v') + v_of(ma,co) = constituent%get_asReal('v') ph_of(ma,co) = phases%index(constituent%get_asString('phase')) - call material_O_0(ma)%data(co)%fromQuaternion(constituent%get_as1dFloat('O',requiredSize=4)) - material_V_e_0(ma)%data(1:3,1:3,co) = constituent%get_as2dFloat('V_e',defaultVal=math_I3,requiredShape=[3,3]) + call material_O_0(ma)%data(co)%fromQuaternion(constituent%get_as1dReal('O',requiredSize=4)) + material_V_e_0(ma)%data(1:3,1:3,co) = constituent%get_as2dReal('V_e',defaultVal=math_I3,requiredShape=[3,3]) if (any(dNeq(material_V_e_0(ma)%data(1:3,1:3,co),transpose(material_V_e_0(ma)%data(1:3,1:3,co))))) & call IO_error(147) diff --git a/src/mesh/DAMASK_mesh.f90 b/src/mesh/DAMASK_mesh.f90 index 29014e49f..a958e2f04 100644 --- a/src/mesh/DAMASK_mesh.f90 +++ b/src/mesh/DAMASK_mesh.f90 @@ -166,7 +166,7 @@ program DAMASK_mesh end do if (currentFaceSet < 0) call IO_error(error_ID = 837, ext_msg = 'invalid BC') case('t') - loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1) + loadCases(currentLoadCase)%time = IO_realValue(line,chunkPos,i+1) case('N') loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1) case('f_out') @@ -191,7 +191,7 @@ program DAMASK_mesh loadCases(currentLoadCase)%fieldBC(1)%componentBC(component)%Mask (currentFaceSet) = & .true. loadCases(currentLoadCase)%fieldBC(1)%componentBC(component)%Value(currentFaceSet) = & - IO_floatValue(line,chunkPos,i+1) + IO_realValue(line,chunkPos,i+1) end if end do end select diff --git a/src/mesh/FEM_quadrature.f90 b/src/mesh/FEM_quadrature.f90 index 518cd1a4e..c54f998fa 100644 --- a/src/mesh/FEM_quadrature.f90 +++ b/src/mesh/FEM_quadrature.f90 @@ -20,13 +20,13 @@ module FEM_quadrature -1.0_pReal, 1.0_pReal, -1.0_pReal, & -1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) - type :: group_float !< variable length datatype + type :: group_real !< variable length datatype real(pReal), dimension(:), allocatable :: p - end type group_float + end type group_real integer, dimension(2:3,maxOrder), public, protected :: & FEM_nQuadrature !< number of quadrature points for spatial dimension(2-3) and interpolation order (1-maxOrder) - type(group_float), dimension(2:3,maxOrder), public, protected :: & + type(group_real), dimension(2:3,maxOrder), public, protected :: & FEM_quadrature_weights, & !< quadrature weights for each quadrature rule FEM_quadrature_points !< quadrature point coordinates (in simplical system) for each quadrature rule diff --git a/src/mesh/mesh_mech_FEM.f90 b/src/mesh/mesh_mech_FEM.f90 index f612968fe..16fe24e19 100644 --- a/src/mesh/mesh_mech_FEM.f90 +++ b/src/mesh/mesh_mech_FEM.f90 @@ -137,8 +137,8 @@ subroutine FEM_mechanical_init(fieldBC) num%p_i = int(num_mesh%get_asInt('p_i',defaultVal = 2),pPETSCINT) num%itmax = int(num_mesh%get_asInt('itmax',defaultVal=250),pPETSCINT) num%BBarStabilisation = num_mesh%get_asBool('bbarstabilisation',defaultVal = .false.) - num%eps_struct_atol = num_mesh%get_asFloat('eps_struct_atol', defaultVal = 1.0e-10_pReal) - num%eps_struct_rtol = num_mesh%get_asFloat('eps_struct_rtol', defaultVal = 1.0e-4_pReal) + num%eps_struct_atol = num_mesh%get_asReal('eps_struct_atol', defaultVal = 1.0e-10_pReal) + num%eps_struct_rtol = num_mesh%get_asReal('eps_struct_rtol', defaultVal = 1.0e-4_pReal) if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') if (num%eps_struct_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_rtol') diff --git a/src/misc.f90 b/src/misc.f90 index a56ea87c1..b3be4de14 100644 --- a/src/misc.f90 +++ b/src/misc.f90 @@ -125,9 +125,9 @@ subroutine misc_selfTest() if (test_int(20191102) /= 20191102) error stop 'optional_int, present' if (test_int() /= 42) error stop 'optional_int, not present' if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only' - if (dNeq(test_real(r),r)) error stop 'optional_float, present' - if (dNeq(test_real(),0.0_pReal)) error stop 'optional_float, not present' - if (dNeq(misc_optional(default=r),r)) error stop 'optional_float, default only' + if (dNeq(test_real(r),r)) error stop 'optional_real, present' + if (dNeq(test_real(),0.0_pReal)) error stop 'optional_real, not present' + if (dNeq(misc_optional(default=r),r)) error stop 'optional_real, default only' if (test_bool(r<0.5_pReal) .neqv. r<0.5_pReal) error stop 'optional_bool, present' if (.not. test_bool()) error stop 'optional_bool, not present' if (misc_optional(default=r>0.5_pReal) .neqv. r>0.5_pReal) error stop 'optional_bool, default only' diff --git a/src/phase.f90 b/src/phase.f90 index 11795f3d6..005d36660 100644 --- a/src/phase.f90 +++ b/src/phase.f90 @@ -402,8 +402,8 @@ subroutine phase_init if (all(phase_lattice(ph) /= ['cF','cI','hP','tI'])) & call IO_error(130,ext_msg='phase_init: '//phase%get_asString('lattice')) if (any(phase_lattice(ph) == ['hP','tI'])) & - phase_cOverA(ph) = phase%get_asFloat('c/a') - phase_rho(ph) = phase%get_asFloat('rho',defaultVal=0.0_pReal) + phase_cOverA(ph) = phase%get_asReal('c/a') + phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pReal) allocate(phase_O_0(ph)%data(count(material_ID_phase==ph))) end do @@ -538,17 +538,17 @@ subroutine crystallite_init() num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict) - num%subStepMinCryst = num_crystallite%get_asFloat ('subStepMin', defaultVal=1.0e-3_pReal) - num%subStepSizeCryst = num_crystallite%get_asFloat ('subStepSize', defaultVal=0.25_pReal) - num%stepIncreaseCryst = num_crystallite%get_asFloat ('stepIncrease', defaultVal=1.5_pReal) - num%subStepSizeLp = num_crystallite%get_asFloat ('subStepSizeLp', defaultVal=0.5_pReal) - num%subStepSizeLi = num_crystallite%get_asFloat ('subStepSizeLi', defaultVal=0.5_pReal) - num%rtol_crystalliteState = num_crystallite%get_asFloat ('rtol_State', defaultVal=1.0e-6_pReal) - num%rtol_crystalliteStress = num_crystallite%get_asFloat ('rtol_Stress', defaultVal=1.0e-6_pReal) - num%atol_crystalliteStress = num_crystallite%get_asFloat ('atol_Stress', defaultVal=1.0e-8_pReal) - num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1) - num%nState = num_crystallite%get_asInt ('nState', defaultVal=20) - num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40) + num%subStepMinCryst = num_crystallite%get_asReal ('subStepMin', defaultVal=1.0e-3_pReal) + num%subStepSizeCryst = num_crystallite%get_asReal ('subStepSize', defaultVal=0.25_pReal) + num%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.5_pReal) + num%subStepSizeLp = num_crystallite%get_asReal ('subStepSizeLp', defaultVal=0.5_pReal) + num%subStepSizeLi = num_crystallite%get_asReal ('subStepSizeLi', defaultVal=0.5_pReal) + num%rtol_crystalliteState = num_crystallite%get_asReal ('rtol_State', defaultVal=1.0e-6_pReal) + num%rtol_crystalliteStress = num_crystallite%get_asReal ('rtol_Stress', defaultVal=1.0e-6_pReal) + num%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pReal) + num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1) + num%nState = num_crystallite%get_asInt ('nState', defaultVal=20) + num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40) extmsg = '' if (num%subStepMinCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepMinCryst' diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index df5e00575..34565d308 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -108,8 +108,8 @@ module subroutine damage_init() refs = config_listReferences(source,indent=3) if (len(refs) > 0) print'(/,1x,a)', refs damage_active = .true. - param(ph)%mu = source%get_asFloat('mu') - param(ph)%l_c = source%get_asFloat('l_c') + param(ph)%mu = source%get_asReal('mu') + param(ph)%l_c = source%get_asReal('l_c') end if end do diff --git a/src/phase_damage_anisobrittle.f90 b/src/phase_damage_anisobrittle.f90 index 69fa32564..427c4aa11 100644 --- a/src/phase_damage_anisobrittle.f90 +++ b/src/phase_damage_anisobrittle.f90 @@ -71,11 +71,11 @@ module function anisobrittle_init() result(mySources) N_cl = src%get_as1dInt('N_cl',defaultVal=emptyIntArray) prm%sum_N_cl = sum(abs(N_cl)) - prm%p = src%get_asFloat('p') - prm%dot_o_0 = src%get_asFloat('dot_o_0') + prm%p = src%get_asReal('p') + prm%dot_o_0 = src%get_asReal('dot_o_0') - prm%s_crit = src%get_as1dFloat('s_crit', requiredSize=size(N_cl)) - prm%g_crit = src%get_as1dFloat('g_crit', requiredSize=size(N_cl)) + prm%s_crit = src%get_as1dReal('s_crit',requiredSize=size(N_cl)) + prm%g_crit = src%get_as1dReal('g_crit',requiredSize=size(N_cl)) prm%cleavage_systems = lattice_SchmidMatrix_cleavage(N_cl,phase_lattice(ph),phase_cOverA(ph)) @@ -97,7 +97,7 @@ module function anisobrittle_init() result(mySources) Nmembers = count(material_ID_phase==ph) call phase_allocateState(damageState(ph),Nmembers,1,1,0) - damageState(ph)%atol = src%get_asFloat('atol_phi',defaultVal=1.0e-9_pReal) + damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' end associate diff --git a/src/phase_damage_isobrittle.f90 b/src/phase_damage_isobrittle.f90 index 62a2eb7ec..569cb3cbb 100644 --- a/src/phase_damage_isobrittle.f90 +++ b/src/phase_damage_isobrittle.f90 @@ -64,7 +64,7 @@ module function isobrittle_init() result(mySources) associate(prm => param(ph), dlt => deltaState(ph), stt => state(ph)) - prm%W_crit = src%get_asFloat('G_crit')/src%get_asFloat('l_c') + prm%W_crit = src%get_asReal('G_crit')/src%get_asReal('l_c') print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph) refs = config_listReferences(src,indent=3) @@ -81,7 +81,7 @@ module function isobrittle_init() result(mySources) Nmembers = count(material_ID_phase==ph) call phase_allocateState(damageState(ph),Nmembers,1,0,1) - damageState(ph)%atol = src%get_asFloat('atol_phi',defaultVal=1.0e-9_pReal) + damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' stt%r_W => damageState(ph)%state(1,:) diff --git a/src/phase_mechanical_plastic_dislotungsten.f90 b/src/phase_mechanical_plastic_dislotungsten.f90 index e37511967..ff949a51e 100644 --- a/src/phase_mechanical_plastic_dislotungsten.f90 +++ b/src/phase_mechanical_plastic_dislotungsten.f90 @@ -151,7 +151,7 @@ module function plastic_dislotungsten_init() result(myPlasticity) prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph)) if (phase_lattice(ph) == 'cI') then - a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) + a = pl%get_as1dReal('a_nonSchmid',defaultVal = emptyRealArray) prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) else @@ -159,30 +159,30 @@ module function plastic_dislotungsten_init() result(myPlasticity) prm%P_nS_neg = prm%P_sl end if - prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'), & + prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'), & phase_lattice(ph)) prm%forestProjection = lattice_forestProjection_edge(N_sl,phase_lattice(ph),& phase_cOverA(ph)) prm%forestProjection = transpose(prm%forestProjection) - rho_mob_0 = pl%get_as1dFloat('rho_mob_0', requiredSize=size(N_sl)) - rho_dip_0 = pl%get_as1dFloat('rho_dip_0', requiredSize=size(N_sl)) - prm%b_sl = pl%get_as1dFloat('b_sl', requiredSize=size(N_sl)) - prm%Q_s = pl%get_as1dFloat('Q_s', requiredSize=size(N_sl)) + rho_mob_0 = pl%get_as1dReal('rho_mob_0', requiredSize=size(N_sl)) + rho_dip_0 = pl%get_as1dReal('rho_dip_0', requiredSize=size(N_sl)) + prm%b_sl = pl%get_as1dReal('b_sl', requiredSize=size(N_sl)) + prm%Q_s = pl%get_as1dReal('Q_s', requiredSize=size(N_sl)) - prm%i_sl = pl%get_as1dFloat('i_sl', requiredSize=size(N_sl)) - prm%tau_Peierls = pl%get_as1dFloat('tau_Peierls', requiredSize=size(N_sl)) - prm%p = pl%get_as1dFloat('p_sl', requiredSize=size(N_sl)) - prm%q = pl%get_as1dFloat('q_sl', requiredSize=size(N_sl)) - prm%h = pl%get_as1dFloat('h', requiredSize=size(N_sl)) - prm%w = pl%get_as1dFloat('w', requiredSize=size(N_sl)) - prm%omega = pl%get_as1dFloat('omega', requiredSize=size(N_sl)) - prm%B = pl%get_as1dFloat('B', requiredSize=size(N_sl)) + prm%i_sl = pl%get_as1dReal('i_sl', requiredSize=size(N_sl)) + prm%tau_Peierls = pl%get_as1dReal('tau_Peierls', requiredSize=size(N_sl)) + prm%p = pl%get_as1dReal('p_sl', requiredSize=size(N_sl)) + prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl)) + prm%h = pl%get_as1dReal('h', requiredSize=size(N_sl)) + prm%w = pl%get_as1dReal('w', requiredSize=size(N_sl)) + prm%omega = pl%get_as1dReal('omega', requiredSize=size(N_sl)) + prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl)) - prm%D = pl%get_asFloat('D') - prm%D_0 = pl%get_asFloat('D_0') - prm%Q_cl = pl%get_asFloat('Q_cl') - prm%f_at = pl%get_asFloat('f_at') * prm%b_sl**3 + prm%D = pl%get_asReal('D') + prm%D_0 = pl%get_asReal('D_0') + prm%Q_cl = pl%get_asReal('Q_cl') + prm%f_at = pl%get_asReal('f_at') * prm%b_sl**3 prm%dipoleformation = .not. pl%get_asBool('no_dipole_formation', defaultVal = .false.) @@ -200,7 +200,7 @@ module function plastic_dislotungsten_init() result(myPlasticity) prm%B = math_expand(prm%B, N_sl) prm%i_sl = math_expand(prm%i_sl, N_sl) prm%f_at = math_expand(prm%f_at, N_sl) - prm%d_caron = pl%get_asFloat('D_a') * prm%b_sl + prm%d_caron = pl%get_asReal('D_a') * prm%b_sl ! sanity checks if ( prm%D_0 < 0.0_pReal) extmsg = trim(extmsg)//' D_0' @@ -239,7 +239,7 @@ module function plastic_dislotungsten_init() result(myPlasticity) idx_dot%rho_mob = [startIndex,endIndex] stt%rho_mob => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob = spread(rho_mob_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' startIndex = endIndex + 1 @@ -247,13 +247,13 @@ module function plastic_dislotungsten_init() result(myPlasticity) idx_dot%rho_dip = [startIndex,endIndex] stt%rho_dip => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip = spread(rho_dip_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pReal) diff --git a/src/phase_mechanical_plastic_dislotwin.f90 b/src/phase_mechanical_plastic_dislotwin.f90 index ee6ccb9d1..7bdeb09fb 100644 --- a/src/phase_mechanical_plastic_dislotwin.f90 +++ b/src/phase_mechanical_plastic_dislotwin.f90 @@ -202,7 +202,7 @@ module function plastic_dislotwin_init() result(myPlasticity) slipActive: if (prm%sum_N_sl > 0) then prm%systems_sl = lattice_labels_slip(N_sl,phase_lattice(ph)) prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph)) - prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'),phase_lattice(ph)) + prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'),phase_lattice(ph)) prm%forestProjection = lattice_forestProjection_edge(N_sl,phase_lattice(ph),phase_cOverA(ph)) prm%forestProjection = transpose(prm%forestProjection) @@ -210,26 +210,26 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%fccTwinTransNucleation = phase_lattice(ph) == 'cF' .and. (N_sl(1) == 12) if (prm%fccTwinTransNucleation) prm%fcc_twinNucleationSlipPair = lattice_CF_TWINNUCLEATIONSLIPPAIR - rho_mob_0 = pl%get_as1dFloat('rho_mob_0', requiredSize=size(N_sl)) - rho_dip_0 = pl%get_as1dFloat('rho_dip_0', requiredSize=size(N_sl)) - prm%v_0 = pl%get_as1dFloat('v_0', requiredSize=size(N_sl)) - prm%b_sl = pl%get_as1dFloat('b_sl', requiredSize=size(N_sl)) - prm%Q_sl = pl%get_as1dFloat('Q_sl', requiredSize=size(N_sl)) - prm%i_sl = pl%get_as1dFloat('i_sl', requiredSize=size(N_sl)) - prm%p = pl%get_as1dFloat('p_sl', requiredSize=size(N_sl)) - prm%q = pl%get_as1dFloat('q_sl', requiredSize=size(N_sl)) - prm%tau_0 = pl%get_as1dFloat('tau_0', requiredSize=size(N_sl)) - prm%B = pl%get_as1dFloat('B', requiredSize=size(N_sl), & - defaultVal=[(0.0_pReal, i=1,size(N_sl))]) + rho_mob_0 = pl%get_as1dReal('rho_mob_0', requiredSize=size(N_sl)) + rho_dip_0 = pl%get_as1dReal('rho_dip_0', requiredSize=size(N_sl)) + prm%v_0 = pl%get_as1dReal('v_0', requiredSize=size(N_sl)) + prm%b_sl = pl%get_as1dReal('b_sl', requiredSize=size(N_sl)) + prm%Q_sl = pl%get_as1dReal('Q_sl', requiredSize=size(N_sl)) + prm%i_sl = pl%get_as1dReal('i_sl', requiredSize=size(N_sl)) + prm%p = pl%get_as1dReal('p_sl', requiredSize=size(N_sl)) + prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl)) + prm%tau_0 = pl%get_as1dReal('tau_0', requiredSize=size(N_sl)) + prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl), & + defaultVal=[(0.0_pReal, i=1,size(N_sl))]) - prm%Q_cl = pl%get_asFloat('Q_cl') + prm%Q_cl = pl%get_asReal('Q_cl') prm%extendedDislocations = pl%get_asBool('extend_dislocations',defaultVal = .false.) prm%omitDipoles = pl%get_asBool('omit_dipoles',defaultVal = .false.) ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex) ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981 - prm%omega = pl%get_asFloat('omega', defaultVal = 1000.0_pReal) & + prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pReal) & * merge(12.0_pReal,8.0_pReal,any(phase_lattice(ph) == ['cF','hP'])) ! expand: family => system @@ -243,7 +243,7 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%q = math_expand(prm%q, N_sl) prm%tau_0 = math_expand(prm%tau_0, N_sl) prm%B = math_expand(prm%B, N_sl) - prm%d_caron = pl%get_asFloat('D_a') * prm%b_sl + prm%d_caron = pl%get_asReal('D_a') * prm%b_sl ! sanity checks if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' @@ -270,15 +270,15 @@ module function plastic_dislotwin_init() result(myPlasticity) twinActive: if (prm%sum_N_tw > 0) then prm%systems_tw = lattice_labels_twin(prm%N_tw,phase_lattice(ph)) prm%P_tw = lattice_SchmidMatrix_twin(prm%N_tw,phase_lattice(ph),phase_cOverA(ph)) - prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,pl%get_as1dFloat('h_tw-tw'), & + prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,pl%get_as1dReal('h_tw-tw'), & phase_lattice(ph)) - prm%b_tw = pl%get_as1dFloat('b_tw', requiredSize=size(prm%N_tw)) - prm%t_tw = pl%get_as1dFloat('t_tw', requiredSize=size(prm%N_tw)) - prm%r = pl%get_as1dFloat('p_tw', requiredSize=size(prm%N_tw)) + prm%b_tw = pl%get_as1dReal('b_tw', requiredSize=size(prm%N_tw)) + prm%t_tw = pl%get_as1dReal('t_tw', requiredSize=size(prm%N_tw)) + prm%r = pl%get_as1dReal('p_tw', requiredSize=size(prm%N_tw)) - prm%L_tw = pl%get_asFloat('L_tw') - prm%i_tw = pl%get_asFloat('i_tw') + prm%L_tw = pl%get_asReal('L_tw') + prm%i_tw = pl%get_asReal('i_tw') prm%gamma_char_tw = lattice_characteristicShear_Twin(prm%N_tw,phase_lattice(ph),phase_cOverA(ph)) @@ -304,25 +304,25 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%N_tr = pl%get_as1dInt('N_tr', defaultVal=emptyIntArray) prm%sum_N_tr = sum(abs(prm%N_tr)) transActive: if (prm%sum_N_tr > 0) then - prm%b_tr = pl%get_as1dFloat('b_tr') + prm%b_tr = pl%get_as1dReal('b_tr') prm%b_tr = math_expand(prm%b_tr,prm%N_tr) - prm%i_tr = pl%get_asFloat('i_tr') + prm%i_tr = pl%get_asReal('i_tr') prm%Delta_G = polynomial(pl,'Delta_G','T') - prm%L_tr = pl%get_asFloat('L_tr') + prm%L_tr = pl%get_asReal('L_tr') a_cF = prm%b_tr(1)*sqrt(6.0_pReal) ! b_tr is Shockley partial prm%h = 5.0_pReal * a_cF/sqrt(3.0_pReal) - prm%cOverA_hP = pl%get_asFloat('c/a_hP') + prm%cOverA_hP = pl%get_asReal('c/a_hP') prm%rho = 4.0_pReal/(sqrt(3.0_pReal)*a_cF**2)/N_A - prm%V_mol = pl%get_asFloat('V_mol') - prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dFloat('h_tr-tr'),& + prm%V_mol = pl%get_asReal('V_mol') + prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dReal('h_tr-tr'),& phase_lattice(ph)) prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr,'hP',prm%cOverA_hP) - prm%t_tr = pl%get_as1dFloat('t_tr') + prm%t_tr = pl%get_as1dReal('t_tr') prm%t_tr = math_expand(prm%t_tr,prm%N_tr) - prm%s = pl%get_as1dFloat('p_tr') + prm%s = pl%get_as1dReal('p_tr') prm%s = math_expand(prm%s,prm%N_tr) ! sanity checks @@ -339,12 +339,12 @@ module function plastic_dislotwin_init() result(myPlasticity) !-------------------------------------------------------------------------------------------------- ! shearband related parameters - prm%gamma_0_sb = pl%get_asFloat('gamma_0_sb',defaultVal=0.0_pReal) + prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pReal) if (prm%gamma_0_sb > 0.0_pReal) then - prm%tau_sb = pl%get_asFloat('tau_sb') - prm%E_sb = pl%get_asFloat('Q_sb') - prm%p_sb = pl%get_asFloat('p_sb') - prm%q_sb = pl%get_asFloat('q_sb') + prm%tau_sb = pl%get_asReal('tau_sb') + prm%E_sb = pl%get_asReal('Q_sb') + prm%p_sb = pl%get_asReal('p_sb') + prm%q_sb = pl%get_asReal('q_sb') ! sanity checks if (prm%tau_sb < 0.0_pReal) extmsg = trim(extmsg)//' tau_sb' @@ -356,11 +356,11 @@ module function plastic_dislotwin_init() result(myPlasticity) !-------------------------------------------------------------------------------------------------- ! parameters required for several mechanisms and their interactions if (prm%sum_N_sl + prm%sum_N_tw + prm%sum_N_tw > 0) & - prm%D = pl%get_asFloat('D') + prm%D = pl%get_asReal('D') if (prm%sum_N_tw + prm%sum_N_tr > 0) then - prm%x_c = pl%get_asFloat('x_c') - prm%V_cs = pl%get_asFloat('V_cs') + prm%x_c = pl%get_asReal('x_c') + prm%V_cs = pl%get_asReal('V_cs') if (prm%x_c < 0.0_pReal) extmsg = trim(extmsg)//' x_c' if (prm%V_cs < 0.0_pReal) extmsg = trim(extmsg)//' V_cs' end if @@ -369,13 +369,13 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%Gamma_sf = polynomial(pl,'Gamma_sf','T') slipAndTwinActive: if (prm%sum_N_sl * prm%sum_N_tw > 0) then - prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,prm%N_tw,pl%get_as1dFloat('h_sl-tw'), & + prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,prm%N_tw,pl%get_as1dReal('h_sl-tw'), & phase_lattice(ph)) if (prm%fccTwinTransNucleation .and. size(prm%N_tw) /= 1) extmsg = trim(extmsg)//' N_tw: nucleation' end if slipAndTwinActive slipAndTransActive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then - prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,prm%N_tr,pl%get_as1dFloat('h_sl-tr'), & + prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,prm%N_tr,pl%get_as1dReal('h_sl-tr'), & phase_lattice(ph)) if (prm%fccTwinTransNucleation .and. size(prm%N_tr) /= 1) extmsg = trim(extmsg)//' N_tr: nucleation' end if slipAndTransActive @@ -402,7 +402,7 @@ module function plastic_dislotwin_init() result(myPlasticity) idx_dot%rho_mob = [startIndex,endIndex] stt%rho_mob=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob= spread(rho_mob_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' startIndex = endIndex + 1 @@ -410,27 +410,27 @@ module function plastic_dislotwin_init() result(myPlasticity) idx_dot%rho_dip = [startIndex,endIndex] stt%rho_dip=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip= spread(rho_dip_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw idx_dot%f_tw = [startIndex,endIndex] stt%f_tw=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_f_tw',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tw',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tw' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tr idx_dot%f_tr = [startIndex,endIndex] stt%f_tr=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_f_tr',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tr',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tr' allocate(dst%tau_pass (prm%sum_N_sl,Nmembers),source=0.0_pReal) diff --git a/src/phase_mechanical_plastic_isotropic.f90 b/src/phase_mechanical_plastic_isotropic.f90 index 7a94e6d8b..39c95c6b8 100644 --- a/src/phase_mechanical_plastic_isotropic.f90 +++ b/src/phase_mechanical_plastic_isotropic.f90 @@ -98,19 +98,19 @@ module function plastic_isotropic_init() result(myPlasticity) prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) #endif - xi_0 = pl%get_asFloat('xi_0') - prm%xi_inf = pl%get_asFloat('xi_inf') - prm%dot_gamma_0 = pl%get_asFloat('dot_gamma_0') - prm%n = pl%get_asFloat('n') - prm%h_0 = pl%get_asFloat('h_0') - prm%h = pl%get_asFloat('h', defaultVal=3.0_pReal) ! match for fcc random polycrystal - prm%M = pl%get_asFloat('M') - prm%h_ln = pl%get_asFloat('h_ln', defaultVal=0.0_pReal) - prm%c_1 = pl%get_asFloat('c_1', defaultVal=0.0_pReal) - prm%c_4 = pl%get_asFloat('c_4', defaultVal=0.0_pReal) - prm%c_3 = pl%get_asFloat('c_3', defaultVal=0.0_pReal) - prm%c_2 = pl%get_asFloat('c_2', defaultVal=0.0_pReal) - prm%a = pl%get_asFloat('a') + xi_0 = pl%get_asReal('xi_0') + prm%xi_inf = pl%get_asReal('xi_inf') + prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0') + prm%n = pl%get_asReal('n') + prm%h_0 = pl%get_asReal('h_0') + prm%h = pl%get_asReal('h', defaultVal=3.0_pReal) ! match for fcc random polycrystal + prm%M = pl%get_asReal('M') + prm%h_ln = pl%get_asReal('h_ln', defaultVal=0.0_pReal) + prm%c_1 = pl%get_asReal('c_1', defaultVal=0.0_pReal) + prm%c_4 = pl%get_asReal('c_4', defaultVal=0.0_pReal) + prm%c_3 = pl%get_asReal('c_3', defaultVal=0.0_pReal) + prm%c_2 = pl%get_asReal('c_2', defaultVal=0.0_pReal) + prm%a = pl%get_asReal('a') prm%dilatation = pl%get_asBool('dilatation',defaultVal = .false.) @@ -135,7 +135,7 @@ module function plastic_isotropic_init() result(myPlasticity) ! state aliases and initialization stt%xi => plasticState(ph)%state(1,:) stt%xi = xi_0 - plasticState(ph)%atol(1) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(1) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) if (plasticState(ph)%atol(1) < 0.0_pReal) extmsg = trim(extmsg)//' atol_xi' end associate diff --git a/src/phase_mechanical_plastic_kinehardening.f90 b/src/phase_mechanical_plastic_kinehardening.f90 index 390d5c7c8..5268d0bb9 100644 --- a/src/phase_mechanical_plastic_kinehardening.f90 +++ b/src/phase_mechanical_plastic_kinehardening.f90 @@ -142,7 +142,7 @@ module function plastic_kinehardening_init() result(myPlasticity) prm%P = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph)) if (phase_lattice(ph) == 'cI') then - a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray) + a = pl%get_as1dReal('a_nonSchmid',defaultVal=emptyRealArray) prm%nonSchmidActive = size(a) > 0 prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) @@ -150,19 +150,19 @@ module function plastic_kinehardening_init() result(myPlasticity) prm%P_nS_pos = prm%P prm%P_nS_neg = prm%P end if - prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'), & + prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'), & phase_lattice(ph)) - xi_0 = pl%get_as1dFloat('xi_0', requiredSize=size(N_sl)) - prm%xi_inf = pl%get_as1dFloat('xi_inf', requiredSize=size(N_sl)) - prm%chi_inf = pl%get_as1dFloat('chi_inf', requiredSize=size(N_sl)) - prm%h_0_xi = pl%get_as1dFloat('h_0_xi', requiredSize=size(N_sl)) - prm%h_0_chi = pl%get_as1dFloat('h_0_chi', requiredSize=size(N_sl)) - prm%h_inf_xi = pl%get_as1dFloat('h_inf_xi', requiredSize=size(N_sl)) - prm%h_inf_chi = pl%get_as1dFloat('h_inf_chi', requiredSize=size(N_sl)) + xi_0 = pl%get_as1dReal('xi_0', requiredSize=size(N_sl)) + prm%xi_inf = pl%get_as1dReal('xi_inf', requiredSize=size(N_sl)) + prm%chi_inf = pl%get_as1dReal('chi_inf', requiredSize=size(N_sl)) + prm%h_0_xi = pl%get_as1dReal('h_0_xi', requiredSize=size(N_sl)) + prm%h_0_chi = pl%get_as1dReal('h_0_chi', requiredSize=size(N_sl)) + prm%h_inf_xi = pl%get_as1dReal('h_inf_xi', requiredSize=size(N_sl)) + prm%h_inf_chi = pl%get_as1dReal('h_inf_chi', requiredSize=size(N_sl)) - prm%dot_gamma_0 = pl%get_asFloat('dot_gamma_0') - prm%n = pl%get_asFloat('n') + prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0') + prm%n = pl%get_asReal('n') ! expand: family => system xi_0 = math_expand(xi_0, N_sl) @@ -208,20 +208,20 @@ module function plastic_kinehardening_init() result(myPlasticity) idx_dot%xi = [startIndex,endIndex] stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi = spread(xi_0, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%chi = [startIndex,endIndex] stt%chi => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma = [startIndex,endIndex] stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' o = plasticState(ph)%offsetDeltaState diff --git a/src/phase_mechanical_plastic_nonlocal.f90 b/src/phase_mechanical_plastic_nonlocal.f90 index aeb647eeb..eca1aa7e5 100644 --- a/src/phase_mechanical_plastic_nonlocal.f90 +++ b/src/phase_mechanical_plastic_nonlocal.f90 @@ -248,7 +248,7 @@ module function plastic_nonlocal_init() result(myPlasticity) plasticState(ph)%nonlocal = pl%get_asBool('flux',defaultVal=.True.) prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain') - prm%atol_rho = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal) + prm%atol_rho = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) ini%N_sl = pl%get_as1dInt('N_sl',defaultVal=emptyIntArray) prm%sum_N_sl = sum(abs(ini%N_sl)) @@ -257,7 +257,7 @@ module function plastic_nonlocal_init() result(myPlasticity) prm%P_sl = lattice_SchmidMatrix_slip(ini%N_sl,phase_lattice(ph), phase_cOverA(ph)) if (phase_lattice(ph) == 'cI') then - a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) + a = pl%get_as1dReal('a_nonSchmid',defaultVal = emptyRealArray) if (size(a) > 0) prm%nonSchmidActive = .true. prm%P_nS_pos = lattice_nonSchmidMatrix(ini%N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1) @@ -266,7 +266,7 @@ module function plastic_nonlocal_init() result(myPlasticity) prm%P_nS_neg = prm%P_sl end if - prm%h_sl_sl = lattice_interaction_SlipBySlip(ini%N_sl,pl%get_as1dFloat('h_sl-sl'), & + prm%h_sl_sl = lattice_interaction_SlipBySlip(ini%N_sl,pl%get_as1dReal('h_sl-sl'), & phase_lattice(ph)) prm%forestProjection_edge = lattice_forestProjection_edge (ini%N_sl,phase_lattice(ph),& @@ -288,65 +288,65 @@ module function plastic_nonlocal_init() result(myPlasticity) end do end do - ini%rho_u_ed_pos_0 = pl%get_as1dFloat('rho_u_ed_pos_0', requiredSize=size(ini%N_sl)) - ini%rho_u_ed_neg_0 = pl%get_as1dFloat('rho_u_ed_neg_0', requiredSize=size(ini%N_sl)) - ini%rho_u_sc_pos_0 = pl%get_as1dFloat('rho_u_sc_pos_0', requiredSize=size(ini%N_sl)) - ini%rho_u_sc_neg_0 = pl%get_as1dFloat('rho_u_sc_neg_0', requiredSize=size(ini%N_sl)) - ini%rho_d_ed_0 = pl%get_as1dFloat('rho_d_ed_0', requiredSize=size(ini%N_sl)) - ini%rho_d_sc_0 = pl%get_as1dFloat('rho_d_sc_0', requiredSize=size(ini%N_sl)) + ini%rho_u_ed_pos_0 = pl%get_as1dReal('rho_u_ed_pos_0', requiredSize=size(ini%N_sl)) + ini%rho_u_ed_neg_0 = pl%get_as1dReal('rho_u_ed_neg_0', requiredSize=size(ini%N_sl)) + ini%rho_u_sc_pos_0 = pl%get_as1dReal('rho_u_sc_pos_0', requiredSize=size(ini%N_sl)) + ini%rho_u_sc_neg_0 = pl%get_as1dReal('rho_u_sc_neg_0', requiredSize=size(ini%N_sl)) + ini%rho_d_ed_0 = pl%get_as1dReal('rho_d_ed_0', requiredSize=size(ini%N_sl)) + ini%rho_d_sc_0 = pl%get_as1dReal('rho_d_sc_0', requiredSize=size(ini%N_sl)) - prm%i_sl = pl%get_as1dFloat('i_sl', requiredSize=size(ini%N_sl)) - prm%b_sl = pl%get_as1dFloat('b_sl', requiredSize=size(ini%N_sl)) + prm%i_sl = pl%get_as1dReal('i_sl', requiredSize=size(ini%N_sl)) + prm%b_sl = pl%get_as1dReal('b_sl', requiredSize=size(ini%N_sl)) prm%i_sl = math_expand(prm%i_sl,ini%N_sl) prm%b_sl = math_expand(prm%b_sl,ini%N_sl) - prm%d_ed = pl%get_as1dFloat('d_ed', requiredSize=size(ini%N_sl)) - prm%d_sc = pl%get_as1dFloat('d_sc', requiredSize=size(ini%N_sl)) + prm%d_ed = pl%get_as1dReal('d_ed', requiredSize=size(ini%N_sl)) + prm%d_sc = pl%get_as1dReal('d_sc', requiredSize=size(ini%N_sl)) prm%d_ed = math_expand(prm%d_ed,ini%N_sl) prm%d_sc = math_expand(prm%d_sc,ini%N_sl) allocate(prm%minDipoleHeight(prm%sum_N_sl,2)) prm%minDipoleHeight(:,1) = prm%d_ed prm%minDipoleHeight(:,2) = prm%d_sc - prm%tau_Peierls_ed = pl%get_as1dFloat('tau_Peierls_ed', requiredSize=size(ini%N_sl)) - prm%tau_Peierls_sc = pl%get_as1dFloat('tau_Peierls_sc', requiredSize=size(ini%N_sl)) + prm%tau_Peierls_ed = pl%get_as1dReal('tau_Peierls_ed', requiredSize=size(ini%N_sl)) + prm%tau_Peierls_sc = pl%get_as1dReal('tau_Peierls_sc', requiredSize=size(ini%N_sl)) prm%tau_Peierls_ed = math_expand(prm%tau_Peierls_ed,ini%N_sl) prm%tau_Peierls_sc = math_expand(prm%tau_Peierls_sc,ini%N_sl) allocate(prm%peierlsstress(prm%sum_N_sl,2)) prm%peierlsstress(:,1) = prm%tau_Peierls_ed prm%peierlsstress(:,2) = prm%tau_Peierls_sc - prm%rho_significant = pl%get_asFloat('rho_significant') - prm%rho_min = pl%get_asFloat('rho_min', 0.0_pReal) - prm%C_CFL = pl%get_asFloat('C_CFL',defaultVal=2.0_pReal) + prm%rho_significant = pl%get_asReal('rho_significant') + prm%rho_min = pl%get_asReal('rho_min', 0.0_pReal) + prm%C_CFL = pl%get_asReal('C_CFL',defaultVal=2.0_pReal) - prm%V_at = pl%get_asFloat('V_at') - prm%D_0 = pl%get_asFloat('D_0') - prm%Q_cl = pl%get_asFloat('Q_cl') - prm%f_F = pl%get_asFloat('f_F') - prm%f_ed = pl%get_asFloat('f_ed') - prm%w = pl%get_asFloat('w') - prm%Q_sol = pl%get_asFloat('Q_sol') - prm%f_sol = pl%get_asFloat('f_sol') - prm%c_sol = pl%get_asFloat('c_sol') + prm%V_at = pl%get_asReal('V_at') + prm%D_0 = pl%get_asReal('D_0') + prm%Q_cl = pl%get_asReal('Q_cl') + prm%f_F = pl%get_asReal('f_F') + prm%f_ed = pl%get_asReal('f_ed') + prm%w = pl%get_asReal('w') + prm%Q_sol = pl%get_asReal('Q_sol') + prm%f_sol = pl%get_asReal('f_sol') + prm%c_sol = pl%get_asReal('c_sol') - prm%p = pl%get_asFloat('p_sl') - prm%q = pl%get_asFloat('q_sl') - prm%B = pl%get_asFloat('B') - prm%nu_a = pl%get_asFloat('nu_a') + prm%p = pl%get_asReal('p_sl') + prm%q = pl%get_asReal('q_sl') + prm%B = pl%get_asReal('B') + prm%nu_a = pl%get_asReal('nu_a') ! ToDo: discuss logic - ini%sigma_rho_u = pl%get_asFloat('sigma_rho_u') - ini%random_rho_u = pl%get_asFloat('random_rho_u',defaultVal= 0.0_pReal) + ini%sigma_rho_u = pl%get_asReal('sigma_rho_u') + ini%random_rho_u = pl%get_asReal('random_rho_u',defaultVal= 0.0_pReal) if (pl%contains('random_rho_u')) & - ini%random_rho_u_binning = pl%get_asFloat('random_rho_u_binning',defaultVal=0.0_pReal) !ToDo: useful default? + ini%random_rho_u_binning = pl%get_asReal('random_rho_u_binning',defaultVal=0.0_pReal) !ToDo: useful default? ! if (rhoSglRandom(instance) < 0.0_pReal) & ! if (rhoSglRandomBinning(instance) <= 0.0_pReal) & - prm%chi_surface = pl%get_asFloat('chi_surface',defaultVal=1.0_pReal) - prm%chi_GB = pl%get_asFloat('chi_GB', defaultVal=-1.0_pReal) - prm%f_ed_mult = pl%get_asFloat('f_ed_mult') + prm%chi_surface = pl%get_asReal('chi_surface',defaultVal=1.0_pReal) + prm%chi_GB = pl%get_asReal('chi_GB', defaultVal=-1.0_pReal) + prm%f_ed_mult = pl%get_asReal('f_ed_mult') prm%shortRangeStressCorrection = pl%get_asBool('short_range_stress_correction', defaultVal = .false.) @@ -491,7 +491,7 @@ module function plastic_nonlocal_init() result(myPlasticity) stt%gamma => plasticState(ph)%state (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) dot%gamma => plasticState(ph)%dotState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) del%gamma => plasticState(ph)%deltaState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) - plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asFloat('atol_gamma', defaultVal = 1.0e-6_pReal) + plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asReal('atol_gamma', defaultVal = 1.0e-6_pReal) if (any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) & extmsg = trim(extmsg)//' atol_gamma' diff --git a/src/phase_mechanical_plastic_phenopowerlaw.f90 b/src/phase_mechanical_plastic_phenopowerlaw.f90 index 11556db78..59b75df87 100644 --- a/src/phase_mechanical_plastic_phenopowerlaw.f90 +++ b/src/phase_mechanical_plastic_phenopowerlaw.f90 @@ -143,7 +143,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph)) if (phase_lattice(ph) == 'cI') then - a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray) + a = pl%get_as1dReal('a_nonSchmid',defaultVal=emptyRealArray) if (size(a) > 0) prm%nonSchmidActive = .true. prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) @@ -151,17 +151,17 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) prm%P_nS_pos = prm%P_sl prm%P_nS_neg = prm%P_sl end if - prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'),phase_lattice(ph)) + prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'),phase_lattice(ph)) - xi_0_sl = pl%get_as1dFloat('xi_0_sl', requiredSize=size(N_sl)) - prm%xi_inf_sl = pl%get_as1dFloat('xi_inf_sl', requiredSize=size(N_sl)) - prm%h_int = pl%get_as1dFloat('h_int', requiredSize=size(N_sl), & + xi_0_sl = pl%get_as1dReal('xi_0_sl', requiredSize=size(N_sl)) + prm%xi_inf_sl = pl%get_as1dReal('xi_inf_sl', requiredSize=size(N_sl)) + prm%h_int = pl%get_as1dReal('h_int', requiredSize=size(N_sl), & defaultVal=[(0.0_pReal,i=1,size(N_sl))]) - prm%dot_gamma_0_sl = pl%get_asFloat('dot_gamma_0_sl') - prm%n_sl = pl%get_asFloat('n_sl') - prm%a_sl = pl%get_asFloat('a_sl') - prm%h_0_sl_sl = pl%get_asFloat('h_0_sl-sl') + prm%dot_gamma_0_sl = pl%get_asReal('dot_gamma_0_sl') + prm%n_sl = pl%get_asReal('n_sl') + prm%a_sl = pl%get_asReal('a_sl') + prm%h_0_sl_sl = pl%get_asReal('h_0_sl-sl') ! expand: family => system xi_0_sl = math_expand(xi_0_sl, N_sl) @@ -187,20 +187,20 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) prm%sum_N_tw = sum(abs(N_tw)) twinActive: if (prm%sum_N_tw > 0) then prm%systems_tw = lattice_labels_twin(N_tw,phase_lattice(ph)) - prm%P_tw = lattice_SchmidMatrix_twin(N_tw,phase_lattice(ph),phase_cOverA(ph)) - prm%h_tw_tw = lattice_interaction_TwinByTwin(N_tw,pl%get_as1dFloat('h_tw-tw'),phase_lattice(ph)) + prm%P_tw = lattice_SchmidMatrix_twin(N_tw,phase_lattice(ph),phase_cOverA(ph)) + prm%h_tw_tw = lattice_interaction_TwinByTwin(N_tw,pl%get_as1dReal('h_tw-tw'),phase_lattice(ph)) prm%gamma_char = lattice_characteristicShear_twin(N_tw,phase_lattice(ph),phase_cOverA(ph)) - xi_0_tw = pl%get_as1dFloat('xi_0_tw',requiredSize=size(N_tw)) + xi_0_tw = pl%get_as1dReal('xi_0_tw',requiredSize=size(N_tw)) - prm%c_1 = pl%get_asFloat('c_1',defaultVal=0.0_pReal) - prm%c_2 = pl%get_asFloat('c_2',defaultVal=1.0_pReal) - prm%c_3 = pl%get_asFloat('c_3',defaultVal=0.0_pReal) - prm%c_4 = pl%get_asFloat('c_4',defaultVal=0.0_pReal) - prm%dot_gamma_0_tw = pl%get_asFloat('dot_gamma_0_tw') - prm%n_tw = pl%get_asFloat('n_tw') - prm%f_sat_sl_tw = pl%get_asFloat('f_sat_sl-tw') - prm%h_0_tw_tw = pl%get_asFloat('h_0_tw-tw') + prm%c_1 = pl%get_asReal('c_1',defaultVal=0.0_pReal) + prm%c_2 = pl%get_asReal('c_2',defaultVal=1.0_pReal) + prm%c_3 = pl%get_asReal('c_3',defaultVal=0.0_pReal) + prm%c_4 = pl%get_asReal('c_4',defaultVal=0.0_pReal) + prm%dot_gamma_0_tw = pl%get_asReal('dot_gamma_0_tw') + prm%n_tw = pl%get_asReal('n_tw') + prm%f_sat_sl_tw = pl%get_asReal('f_sat_sl-tw') + prm%h_0_tw_tw = pl%get_asReal('h_0_tw-tw') ! expand: family => system xi_0_tw = math_expand(xi_0_tw,N_tw) @@ -218,10 +218,10 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) !-------------------------------------------------------------------------------------------------- ! slip-twin related parameters slipAndTwinActive: if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then - prm%h_0_tw_sl = pl%get_asFloat('h_0_tw-sl') - prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,pl%get_as1dFloat('h_sl-tw'), & + prm%h_0_tw_sl = pl%get_asReal('h_0_tw-sl') + prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,pl%get_as1dReal('h_sl-tw'), & phase_lattice(ph)) - prm%h_tw_sl = lattice_interaction_TwinBySlip(N_tw,N_sl,pl%get_as1dFloat('h_tw-sl'), & + prm%h_tw_sl = lattice_interaction_TwinBySlip(N_tw,N_sl,pl%get_as1dReal('h_tw-sl'), & phase_lattice(ph)) else slipAndTwinActive allocate(prm%h_sl_tw(prm%sum_N_sl,prm%sum_N_tw)) ! at least one dimension is 0 @@ -246,7 +246,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) idx_dot%xi_sl = [startIndex,endIndex] stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl = spread(xi_0_sl, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 @@ -254,20 +254,20 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) idx_dot%xi_tw = [startIndex,endIndex] stt%xi_tw => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_tw = spread(xi_0_tw, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw idx_dot%gamma_tw = [startIndex,endIndex] stt%gamma_tw => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) end associate diff --git a/src/phase_thermal.f90 b/src/phase_thermal.f90 index 1371f3b7f..878d2c9ae 100644 --- a/src/phase_thermal.f90 +++ b/src/phase_thermal.f90 @@ -109,9 +109,9 @@ module subroutine thermal_init(phases) print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph) refs = config_listReferences(thermal,indent=3) if (len(refs) > 0) print'(/,1x,a)', refs - param(ph)%C_p = thermal%get_asFloat('C_p') - param(ph)%K(1,1) = thermal%get_asFloat('K_11') - if (any(phase_lattice(ph) == ['hP','tI'])) param(ph)%K(3,3) = thermal%get_asFloat('K_33') + param(ph)%C_p = thermal%get_asReal('C_p') + param(ph)%K(1,1) = thermal%get_asReal('K_11') + if (any(phase_lattice(ph) == ['hP','tI'])) param(ph)%K(3,3) = thermal%get_asReal('K_33') param(ph)%K = lattice_symmetrize_33(param(ph)%K,phase_lattice(ph)) #if defined(__GFORTRAN__) diff --git a/src/phase_thermal_dissipation.f90 b/src/phase_thermal_dissipation.f90 index 66bde6808..74d7cd46f 100644 --- a/src/phase_thermal_dissipation.f90 +++ b/src/phase_thermal_dissipation.f90 @@ -61,7 +61,7 @@ module function dissipation_init(source_length) result(mySources) refs = config_listReferences(src,indent=3) if (len(refs) > 0) print'(/,1x,a)', refs - prm%kappa = src%get_asFloat('kappa') + prm%kappa = src%get_asReal('kappa') Nmembers = count(material_ID_phase == ph) call phase_allocateState(thermalState(ph)%p(so),Nmembers,0,0,0) diff --git a/src/polynomials.f90 b/src/polynomials.f90 index 2240616f7..1e1f2b842 100644 --- a/src/polynomials.f90 +++ b/src/polynomials.f90 @@ -73,17 +73,17 @@ function polynomial_from_dict(dict,y,x) result(p) character(len=1) :: o_s - allocate(coef(1),source=dict%get_asFloat(y)) + allocate(coef(1),source=dict%get_asReal(y)) if (dict%contains(y//','//x)) then - x_ref = dict%get_asFloat(x//'_ref') - coef = [coef,dict%get_asFloat(y//','//x)] + x_ref = dict%get_asReal(x//'_ref') + coef = [coef,dict%get_asReal(y//','//x)] end if do o = 2,4 write(o_s,'(I0.0)') o if (dict%contains(y//','//x//'^'//o_s)) then - x_ref = dict%get_asFloat(x//'_ref') - coef = [coef,[(0.0_pReal,i=size(coef),o-1)],dict%get_asFloat(y//','//x//'^'//o_s)] + x_ref = dict%get_asReal(x//'_ref') + coef = [coef,[(0.0_pReal,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)] end if end do diff --git a/src/prec.f90 b/src/prec.f90 index a3ec72251..ccf6dc9f9 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -52,13 +52,13 @@ subroutine prec_init() print'(/,1x,a)', '<<<+- prec init -+>>>' - print'(/,a,i3)', ' integer size / bit: ',bit_size(0) - print'( a,i19)', ' maximum value: ',huge(0) - print'(/,a,i3)', ' float size / bit: ',storage_size(0.0_pReal) - print'( a,e10.3)', ' maximum value: ',huge(0.0_pReal) - print'( a,e10.3)', ' minimum value: ',PREAL_MIN - print'( a,e10.3)', ' epsilon value: ',PREAL_EPSILON - print'( a,i3)', ' decimal precision: ',precision(0.0_pReal) + print'(/,a,i3)', ' integer size / bit: ',bit_size(0) + print'( a,i19)', ' maximum value: ',huge(0) + print'(/,a,i3)', ' real size / bit: ',storage_size(0.0_pReal) + print'( a,e10.3)', ' maximum value: ',huge(0.0_pReal) + print'( a,e10.3)', ' minimum value: ',PREAL_MIN + print'( a,e10.3)', ' epsilon value: ',PREAL_EPSILON + print'( a,i3)', ' decimal precision: ',precision(0.0_pReal) call prec_selfTest() diff --git a/src/tables.f90 b/src/tables.f90 index c62082705..b4e63e303 100644 --- a/src/tables.f90 +++ b/src/tables.f90 @@ -75,7 +75,7 @@ function table_from_dict(dict,x_label,y_label) result(t) type(tTable) :: t - t = tTable(dict%get_as1dFloat(x_label),dict%get_as1dFloat(y_label)) + t = tTable(dict%get_as1dReal(x_label),dict%get_as1dReal(y_label)) end function table_from_dict From d00a530d2d299487f2eab6f2daae9258ef5d394c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Jun 2023 10:35:20 +0200 Subject: [PATCH 2/7] f_phi factor corrected --- PRIVATE | 2 +- src/phase_damage.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/PRIVATE b/PRIVATE index 22a23a9d5..4cd6c7350 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 22a23a9d5939d49d9d277c7066d9b68003a33324 +Subproject commit 4cd6c7350b0a9d4ad3efcb5fe6c6cfffa99c426f diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index df5e00575..af0a8fb7e 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -210,7 +210,7 @@ module function phase_f_phi(phi,co,ce) result(f) select case(phase_damage(ph)) case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID) f = 1.0_pReal & - - phi*damageState(ph)%state(1,en) + - 2.0_pREAL * phi*damageState(ph)%state(1,en) case default f = 0.0_pReal end select From ca1c22874bcb1bdc6a166da3a1ea53faae5994b7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Jun 2023 07:17:38 +0200 Subject: [PATCH 3/7] consistent and short --- src/CLI.f90 | 2 +- src/IO.f90 | 236 +++++++-------- src/Marc/DAMASK_Marc.f90 | 2 +- src/Marc/discretization_Marc.f90 | 108 +++---- src/YAML_parse.f90 | 18 +- src/YAML_types.f90 | 268 +++++++++--------- src/config.f90 | 2 +- src/grid/DAMASK_grid.f90 | 18 +- src/grid/VTI.f90 | 8 +- src/grid/grid_damage_spectral.f90 | 4 +- src/grid/grid_mech_FEM.f90 | 4 +- src/grid/grid_mech_spectral_basic.f90 | 4 +- src/grid/grid_mech_spectral_polarisation.f90 | 4 +- src/grid/grid_thermal_spectral.f90 | 2 +- src/grid/spectral_utilities.f90 | 12 +- src/homogenization.f90 | 8 +- src/homogenization_damage.f90 | 8 +- src/homogenization_mechanical.f90 | 12 +- src/homogenization_mechanical_RGC.f90 | 6 +- src/homogenization_thermal.f90 | 10 +- src/material.f90 | 8 +- src/mesh/DAMASK_mesh.f90 | 14 +- src/mesh/FEM_utilities.f90 | 4 +- src/mesh/mesh_mech_FEM.f90 | 2 +- src/misc.f90 | 14 +- src/parallelization.f90 | 14 +- src/phase.f90 | 4 +- src/phase_damage.f90 | 2 +- src/phase_damage_anisobrittle.f90 | 6 +- src/phase_damage_isobrittle.f90 | 6 +- src/phase_mechanical.f90 | 8 +- src/phase_mechanical_eigen.f90 | 4 +- src/phase_mechanical_elastic.f90 | 2 +- src/phase_mechanical_plastic.f90 | 2 +- ...phase_mechanical_plastic_dislotungsten.f90 | 8 +- src/phase_mechanical_plastic_dislotwin.f90 | 8 +- src/phase_mechanical_plastic_isotropic.f90 | 6 +- ...phase_mechanical_plastic_kinehardening.f90 | 8 +- src/phase_mechanical_plastic_nonlocal.f90 | 8 +- ...phase_mechanical_plastic_phenopowerlaw.f90 | 6 +- src/phase_thermal.f90 | 8 +- src/polynomials.f90 | 4 +- src/prec.f90 | 8 +- src/result.f90 | 22 +- src/system_routines.f90 | 12 +- 45 files changed, 462 insertions(+), 462 deletions(-) diff --git a/src/CLI.f90 b/src/CLI.f90 index aba6e542f..ac1353b10 100644 --- a/src/CLI.f90 +++ b/src/CLI.f90 @@ -42,7 +42,7 @@ subroutine CLI_init -- UNSUPPORTED PETSc VERSION --- UNSUPPORTED PETSc VERSION --- UNSUPPORTED PETSc VERSION --- #endif - character(len=pPathLen*3+pStringLen) :: & + character(len=pPathLen*3+pSTRLEN) :: & commandLine !< command line call as string character(len=pPathLen) :: & arg, & !< individual argument diff --git a/src/IO.f90 b/src/IO.f90 index 315bc9fb5..31ce19c29 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -32,16 +32,16 @@ module IO IO_readlines, & IO_isBlank, & IO_wrapLines, & - IO_stringPos, & - IO_stringValue, & + IO_strPos, & + IO_strValue, & IO_intValue, & IO_realValue, & IO_lc, & IO_rmComment, & - IO_intAsString, & - IO_stringAsInt, & - IO_stringAsReal, & - IO_stringAsBool, & + IO_intAsStr, & + IO_strAsInt, & + IO_strAsReal, & + IO_strAsBool, & IO_error, & IO_warning, & IO_STDOUT @@ -66,11 +66,11 @@ end subroutine IO_init !-------------------------------------------------------------------------------------------------- function IO_readlines(fileName) result(fileContent) - character(len=*), intent(in) :: fileName - character(len=pStringLen), dimension(:), allocatable :: fileContent !< file content, separated per lines + character(len=*), intent(in) :: fileName + character(len=pSTRLEN), dimension(:), allocatable :: fileContent !< file content, separated per lines - character(len=pStringLen) :: line - character(len=:), allocatable :: rawData + character(len=pSTRLEN) :: line + character(len=:), allocatable :: rawData integer :: & startPos, endPos, & N_lines, & !< # lines in file @@ -90,8 +90,8 @@ function IO_readlines(fileName) result(fileContent) l = 1 do while (l <= N_lines) endPos = startPos + scan(rawData(startPos:),IO_EOL) - 2 - if (endPos - startPos > pStringLen-1) then - line = rawData(startPos:startPos+pStringLen-1) + if (endPos - startPos > pSTRLEN-1) then + line = rawData(startPos:startPos+pSTRLEN-1) if (.not. warned) then call IO_warning(207,trim(fileName),label1='line',ID1=l) warned = .true. @@ -147,15 +147,15 @@ end function IO_read !-------------------------------------------------------------------------------------------------- !> @brief Identifiy strings without content. !-------------------------------------------------------------------------------------------------- -logical pure function IO_isBlank(string) +logical pure function IO_isBlank(str) - character(len=*), intent(in) :: string !< string to check for content + character(len=*), intent(in) :: str !< string to check for content integer :: posNonBlank - posNonBlank = verify(string,IO_WHITESPACE) - IO_isBlank = posNonBlank == 0 .or. posNonBlank == scan(string,IO_COMMENT) + posNonBlank = verify(str,IO_WHITESPACE) + IO_isBlank = posNonBlank == 0 .or. posNonBlank == scan(str,IO_COMMENT) end function IO_isBlank @@ -163,9 +163,9 @@ end function IO_isBlank !-------------------------------------------------------------------------------------------------- !> @brief Insert EOL at separator trying to keep line length below limit. !-------------------------------------------------------------------------------------------------- -function IO_wrapLines(string,separator,filler,length) +function IO_wrapLines(str,separator,filler,length) - character(len=*), intent(in) :: string !< string to split + character(len=*), intent(in) :: str !< string to split character, optional, intent(in) :: separator !< line breaks are possible after this character, defaults to ',' character(len=*), optional, intent(in) :: filler !< character(s) to insert after line break, defaults to none integer, optional, intent(in) :: length !< (soft) line limit, defaults to 80 @@ -175,18 +175,18 @@ function IO_wrapLines(string,separator,filler,length) integer :: i,s,e - i = index(string,misc_optional(separator,',')) + i = index(str,misc_optional(separator,',')) if (i == 0) then - IO_wrapLines = string + IO_wrapLines = str else pos_sep = [0] s = i - do while (i /= 0 .and. s < len(string)) + do while (i /= 0 .and. s < len(str)) pos_sep = [pos_sep,s] - i = index(string(s+1:),misc_optional(separator,',')) + i = index(str(s+1:),misc_optional(separator,',')) s = s + i end do - pos_sep = [pos_sep,len(string)] + pos_sep = [pos_sep,len(str)] pos_split = emptyIntArray s = 1 @@ -194,12 +194,12 @@ function IO_wrapLines(string,separator,filler,length) IO_wrapLines = '' do while (e < size(pos_sep)) if (pos_sep(e+1) - pos_sep(s) >= misc_optional(length,80)) then - IO_wrapLines = IO_wrapLines//adjustl(string(pos_sep(s)+1:pos_sep(e)))//IO_EOL//misc_optional(filler,'') + IO_wrapLines = IO_wrapLines//adjustl(str(pos_sep(s)+1:pos_sep(e)))//IO_EOL//misc_optional(filler,'') s = e end if e = e + 1 end do - IO_wrapLines = IO_wrapLines//adjustl(string(pos_sep(s)+1:)) + IO_wrapLines = IO_wrapLines//adjustl(str(pos_sep(s)+1:)) end if end function IO_wrapLines @@ -211,62 +211,62 @@ end function IO_wrapLines !! Array size is dynamically adjusted to number of chunks found in string !! IMPORTANT: first element contains number of chunks! !-------------------------------------------------------------------------------------------------- -pure function IO_stringPos(string) +pure function IO_strPos(str) - character(len=*), intent(in) :: string !< string in which chunk positions are searched for - integer, dimension(:), allocatable :: IO_stringPos + character(len=*), intent(in) :: str !< string in which chunk positions are searched for + integer, dimension(:), allocatable :: IO_strPos integer :: left, right - allocate(IO_stringPos(1), source=0) + allocate(IO_strPos(1), source=0) right = 0 - do while (verify(string(right+1:),IO_WHITESPACE)>0) - left = right + verify(string(right+1:),IO_WHITESPACE) - right = left + scan(string(left:),IO_WHITESPACE) - 2 - if ( string(left:left) == IO_COMMENT) exit - IO_stringPos = [IO_stringPos,left,right] - IO_stringPos(1) = IO_stringPos(1)+1 - endOfString: if (right < left) then - IO_stringPos(IO_stringPos(1)*2+1) = len_trim(string) + do while (verify(str(right+1:),IO_WHITESPACE)>0) + left = right + verify(str(right+1:),IO_WHITESPACE) + right = left + scan(str(left:),IO_WHITESPACE) - 2 + if ( str(left:left) == IO_COMMENT) exit + IO_strPos = [IO_strPos,left,right] + IO_strPos(1) = IO_strPos(1)+1 + endOfStr: if (right < left) then + IO_strPos(IO_strPos(1)*2+1) = len_trim(str) exit - end if endOfString + end if endOfStr end do -end function IO_stringPos +end function IO_strPos !-------------------------------------------------------------------------------------------------- !> @brief Read string value at myChunk from string. !-------------------------------------------------------------------------------------------------- -function IO_stringValue(string,chunkPos,myChunk) +function IO_strValue(str,chunkPos,myChunk) - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + character(len=*), intent(in) :: str !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk - character(len=:), allocatable :: IO_stringValue + character(len=:), allocatable :: IO_strValue validChunk: if (myChunk > chunkPos(1) .or. myChunk < 1) then - IO_stringValue = '' - call IO_error(110,'IO_stringValue: "'//trim(string)//'"',label1='chunk',ID1=myChunk) + IO_strValue = '' + call IO_error(110,'IO_strValue: "'//trim(str)//'"',label1='chunk',ID1=myChunk) else validChunk - IO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) + IO_strValue = str(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) end if validChunk -end function IO_stringValue +end function IO_strValue !-------------------------------------------------------------------------------------------------- !> @brief Read integer value at myChunk from string. !-------------------------------------------------------------------------------------------------- -integer function IO_intValue(string,chunkPos,myChunk) +integer function IO_intValue(str,chunkPos,myChunk) - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + character(len=*), intent(in) :: str !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk - IO_intValue = IO_stringAsInt(IO_stringValue(string,chunkPos,myChunk)) + IO_intValue = IO_strAsInt(IO_strValue(str,chunkPos,myChunk)) end function IO_intValue @@ -274,13 +274,13 @@ end function IO_intValue !-------------------------------------------------------------------------------------------------- !> @brief Read real value at myChunk from string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_realValue(string,chunkPos,myChunk) +real(pReal) function IO_realValue(str,chunkPos,myChunk) - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + character(len=*), intent(in) :: str !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, intent(in) :: myChunk !< position number of desired chunk - IO_realValue = IO_stringAsReal(IO_stringValue(string,chunkPos,myChunk)) + IO_realValue = IO_strAsReal(IO_strValue(str,chunkPos,myChunk)) end function IO_realValue @@ -288,10 +288,10 @@ end function IO_realValue !-------------------------------------------------------------------------------------------------- !> @brief Convert characters in string to lower case. !-------------------------------------------------------------------------------------------------- -pure function IO_lc(string) +pure function IO_lc(str) - character(len=*), intent(in) :: string !< string to convert - character(len=len(string)) :: IO_lc + character(len=*), intent(in) :: str !< string to convert + character(len=len(str)) :: IO_lc character(len=*), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz' character(len=len(LOWER)), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' @@ -299,10 +299,10 @@ pure function IO_lc(string) integer :: i,n - do i = 1,len(string) - n = index(UPPER,string(i:i)) + do i = 1,len(str) + n = index(UPPER,str(i:i)) if (n==0) then - IO_lc(i:i) = string(i:i) + IO_lc(i:i) = str(i:i) else IO_lc(i:i) = LOWER(n:n) end if @@ -336,80 +336,80 @@ end function IO_rmComment !-------------------------------------------------------------------------------------------------- !> @brief Return given int value as string. !-------------------------------------------------------------------------------------------------- -function IO_intAsString(i) +function IO_intAsStr(i) integer, intent(in) :: i - character(len=:), allocatable :: IO_intAsString + character(len=:), allocatable :: IO_intAsStr - allocate(character(len=merge(2,1,i<0) + floor(log10(real(abs(merge(1,i,i==0))))))::IO_intAsString) - write(IO_intAsString,'(i0)') i + allocate(character(len=merge(2,1,i<0) + floor(log10(real(abs(merge(1,i,i==0))))))::IO_intAsStr) + write(IO_intAsStr,'(i0)') i -end function IO_intAsString +end function IO_intAsStr !-------------------------------------------------------------------------------------------------- !> @brief Return integer value from given string. !-------------------------------------------------------------------------------------------------- -integer function IO_stringAsInt(string) +integer function IO_strAsInt(str) - character(len=*), intent(in) :: string !< string for conversion to int value + character(len=*), intent(in) :: str !< string for conversion to int value integer :: readStatus character(len=*), parameter :: VALIDCHARS = '0123456789+- ' - valid: if (verify(string,VALIDCHARS) == 0) then - read(string,*,iostat=readStatus) IO_stringAsInt - if (readStatus /= 0) call IO_error(111,string) + valid: if (verify(str,VALIDCHARS) == 0) then + read(str,*,iostat=readStatus) IO_strAsInt + if (readStatus /= 0) call IO_error(111,str) else valid - IO_stringAsInt = 0 - call IO_error(111,string) + IO_strAsInt = 0 + call IO_error(111,str) end if valid -end function IO_stringAsInt +end function IO_strAsInt !-------------------------------------------------------------------------------------------------- !> @brief Return real value from given string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_stringAsReal(string) +real(pReal) function IO_strAsReal(str) - character(len=*), intent(in) :: string !< string for conversion to real value + character(len=*), intent(in) :: str !< string for conversion to real value integer :: readStatus character(len=*), parameter :: VALIDCHARS = '0123456789eE.+- ' - valid: if (verify(string,VALIDCHARS) == 0) then - read(string,*,iostat=readStatus) IO_stringAsReal - if (readStatus /= 0) call IO_error(112,string) + valid: if (verify(str,VALIDCHARS) == 0) then + read(str,*,iostat=readStatus) IO_strAsReal + if (readStatus /= 0) call IO_error(112,str) else valid - IO_stringAsReal = 0.0_pReal - call IO_error(112,string) + IO_strAsReal = 0.0_pReal + call IO_error(112,str) end if valid -end function IO_stringAsReal +end function IO_strAsReal !-------------------------------------------------------------------------------------------------- !> @brief Return logical value from given string. !-------------------------------------------------------------------------------------------------- -logical function IO_stringAsBool(string) +logical function IO_strAsBool(str) - character(len=*), intent(in) :: string !< string for conversion to int value + character(len=*), intent(in) :: str !< string for conversion to int value - if (trim(adjustl(string)) == 'True' .or. trim(adjustl(string)) == 'true') then - IO_stringAsBool = .true. - elseif (trim(adjustl(string)) == 'False' .or. trim(adjustl(string)) == 'false') then - IO_stringAsBool = .false. + if (trim(adjustl(str)) == 'True' .or. trim(adjustl(str)) == 'true') then + IO_strAsBool = .true. + elseif (trim(adjustl(str)) == 'False' .or. trim(adjustl(str)) == 'false') then + IO_strAsBool = .false. else - IO_stringAsBool = .false. - call IO_error(113,string) + IO_strAsBool = .false. + call IO_error(113,str) end if -end function IO_stringAsBool +end function IO_strAsBool @@ -647,22 +647,22 @@ end subroutine IO_warning !-------------------------------------------------------------------------------------------------- !> @brief Convert Windows (CRLF) to Unix (LF) line endings. !-------------------------------------------------------------------------------------------------- -pure function CRLF2LF(string) +pure function CRLF2LF(str) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: str character(len=:), allocatable :: CRLF2LF integer(pI64) :: c,n - allocate(character(len=len_trim(string,pI64))::CRLF2LF) + allocate(character(len=len_trim(str,pI64))::CRLF2LF) if (len(CRLF2LF,pI64) == 0) return n = 0_pI64 - do c=1_pI64, len_trim(string,pI64) - CRLF2LF(c-n:c-n) = string(c:c) - if (c == len_trim(string,pI64)) exit - if (string(c:c+1_pI64) == CR//LF) n = n + 1_pI64 + do c=1_pI64, len_trim(str,pI64) + CRLF2LF(c-n:c-n) = str(c:c) + if (c == len_trim(str,pI64)) exit + if (str(c:c+1_pI64) == CR//LF) n = n + 1_pI64 end do CRLF2LF = CRLF2LF(:c-n) @@ -680,7 +680,7 @@ subroutine panel(paneltype,ID,msg,ext_msg,label1,ID1,label2,ID2) integer, intent(in) :: ID integer, optional, intent(in) :: ID1,ID2 - character(len=pStringLen) :: formatString + character(len=pSTRLEN) :: formatString integer, parameter :: panelwidth = 69 character(len=*), parameter :: DIVIDER = repeat('─',panelwidth) @@ -733,37 +733,37 @@ subroutine selfTest() character(len=:), allocatable :: str,out - if (dNeq(1.0_pReal, IO_stringAsReal('1.0'))) error stop 'IO_stringAsReal' - if (dNeq(1.0_pReal, IO_stringAsReal('1e0'))) error stop 'IO_stringAsReal' - if (dNeq(0.1_pReal, IO_stringAsReal('1e-1'))) error stop 'IO_stringAsReal' - if (dNeq(0.1_pReal, IO_stringAsReal('1.0e-1'))) error stop 'IO_stringAsReal' - if (dNeq(0.1_pReal, IO_stringAsReal('1.00e-1'))) error stop 'IO_stringAsReal' - if (dNeq(10._pReal, IO_stringAsReal(' 1.0e+1 '))) error stop 'IO_stringAsReal' + if (dNeq(1.0_pReal, IO_strAsReal('1.0'))) error stop 'IO_strAsReal' + if (dNeq(1.0_pReal, IO_strAsReal('1e0'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pReal, IO_strAsReal('1e-1'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pReal, IO_strAsReal('1.0e-1'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pReal, IO_strAsReal('1.00e-1'))) error stop 'IO_strAsReal' + if (dNeq(10._pReal, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal' - if (3112019 /= IO_stringAsInt( '3112019')) error stop 'IO_stringAsInt' - if (3112019 /= IO_stringAsInt(' 3112019')) error stop 'IO_stringAsInt' - if (-3112019 /= IO_stringAsInt('-3112019')) error stop 'IO_stringAsInt' - if (3112019 /= IO_stringAsInt('+3112019 ')) error stop 'IO_stringAsInt' - if (3112019 /= IO_stringAsInt('03112019 ')) error stop 'IO_stringAsInt' - if (3112019 /= IO_stringAsInt('+03112019')) error stop 'IO_stringAsInt' + if (3112019 /= IO_strAsInt( '3112019')) error stop 'IO_strAsInt' + if (3112019 /= IO_strAsInt(' 3112019')) error stop 'IO_strAsInt' + if (-3112019 /= IO_strAsInt('-3112019')) error stop 'IO_strAsInt' + if (3112019 /= IO_strAsInt('+3112019 ')) error stop 'IO_strAsInt' + if (3112019 /= IO_strAsInt('03112019 ')) error stop 'IO_strAsInt' + if (3112019 /= IO_strAsInt('+03112019')) error stop 'IO_strAsInt' - if (.not. IO_stringAsBool(' true')) error stop 'IO_stringAsBool' - if (.not. IO_stringAsBool(' True ')) error stop 'IO_stringAsBool' - if ( IO_stringAsBool(' false')) error stop 'IO_stringAsBool' - if ( IO_stringAsBool('False')) error stop 'IO_stringAsBool' + if (.not. IO_strAsBool(' true')) error stop 'IO_strAsBool' + if (.not. IO_strAsBool(' True ')) error stop 'IO_strAsBool' + if ( IO_strAsBool(' false')) error stop 'IO_strAsBool' + if ( IO_strAsBool('False')) error stop 'IO_strAsBool' - if ('1234' /= IO_intAsString(1234)) error stop 'IO_intAsString' - if ('-12' /= IO_intAsString(-0012)) error stop 'IO_intAsString' + if ('1234' /= IO_intAsStr(1234)) error stop 'IO_intAsStr' + if ('-12' /= IO_intAsStr(-0012)) error stop 'IO_intAsStr' - if (any([1,1,1] /= IO_stringPos('a'))) error stop 'IO_stringPos' - if (any([2,2,3,5,5] /= IO_stringPos(' aa b'))) error stop 'IO_stringPos' + if (any([1,1,1] /= IO_strPos('a'))) error stop 'IO_strPos' + if (any([2,2,3,5,5] /= IO_strPos(' aa b'))) error stop 'IO_strPos' str = ' 1.0 xxx' - chunkPos = IO_stringPos(str) + chunkPos = IO_strPos(str) if (dNeq(1.0_pReal,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue' str = 'M 3112019 F' - chunkPos = IO_stringPos(str) + chunkPos = IO_strPos(str) if (3112019 /= IO_intValue(str,chunkPos,2)) error stop 'IO_intValue' if (CRLF2LF('') /= '') error stop 'CRLF2LF/0' diff --git a/src/Marc/DAMASK_Marc.f90 b/src/Marc/DAMASK_Marc.f90 index 92b89c334..1b978c0cb 100644 --- a/src/Marc/DAMASK_Marc.f90 +++ b/src/Marc/DAMASK_Marc.f90 @@ -98,7 +98,7 @@ end function getSolverJobName !-------------------------------------------------------------------------------------------------- logical function solverIsSymmetric() - character(len=pStringLen) :: line + character(len=pSTRLEN) :: line integer :: myStat,fileUnit,s,e open(newunit=fileUnit, file=getSolverJobName()//INPUTFILEEXTENSION, & diff --git a/src/Marc/discretization_Marc.f90 b/src/Marc/discretization_Marc.f90 index cdc7863ca..51459f1f2 100644 --- a/src/Marc/discretization_Marc.f90 +++ b/src/Marc/discretization_Marc.f90 @@ -202,7 +202,7 @@ subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt) nElems integer, dimension(:), allocatable :: & matNumber !< material numbers for hypoelastic material - character(len=pStringLen), dimension(:), allocatable :: & + character(len=pSTRLEN), dimension(:), allocatable :: & inputFile, & !< file content, separated per lines nameElemSet integer, dimension(:,:), allocatable :: & @@ -263,9 +263,9 @@ subroutine inputRead_fileFormat(fileFormat,fileContent) integer :: l do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 2) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'version') then fileFormat = IO_intValue(fileContent(l),chunkPos,2) exit end if @@ -289,9 +289,9 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent) hypoelastic = 0 do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 6) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'table') then initialcond = IO_intValue(fileContent(l),chunkPos,4) hypoelastic = IO_intValue(fileContent(l),chunkPos,5) exit @@ -316,11 +316,11 @@ subroutine inputRead_matNumber(matNumber, & do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then if (len_trim(fileContent(l+1))/=0) then - chunkPos = IO_stringPos(fileContent(l+1)) + chunkPos = IO_strPos(fileContent(l+1)) data_blocks = IO_intValue(fileContent(l+1),chunkPos,1) else data_blocks = 1 @@ -328,7 +328,7 @@ subroutine inputRead_matNumber(matNumber, & allocate(matNumber(data_blocks), source = 0) do i = 0, data_blocks - 1 j = i*(2+tableStyle) + 1 - chunkPos = IO_stringPos(fileContent(l+1+j)) + chunkPos = IO_strPos(fileContent(l+1+j)) matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1) end do exit @@ -354,12 +354,12 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,& nElems = 0 do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then + if (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'sizing') then nElems = IO_IntValue (fileContent(l),chunkPos,3) - elseif (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then - chunkPos = IO_stringPos(fileContent(l+1)) + elseif (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'coordinates') then + chunkPos = IO_strPos(fileContent(l+1)) nNodes = IO_IntValue (fileContent(l+1),chunkPos,2) end if end do @@ -384,13 +384,13 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,& maxNelemInSet = 0 do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 2) cycle - if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. & - IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then + if (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'define' .and. & + IO_lc(IO_StrValue(fileContent(l),chunkPos,2)) == 'element') then nElemSets = nElemSets + 1 - chunkPos = IO_stringPos(fileContent(l+1)) + chunkPos = IO_strPos(fileContent(l+1)) if (containsRange(fileContent(l+1),chunkPos)) then elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) & -IO_intValue(fileContent(l+1),chunkPos,1)) @@ -399,9 +399,9 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,& i = 0 do while (.true.) i = i + 1 - chunkPos = IO_stringPos(fileContent(l+i)) + chunkPos = IO_strPos(fileContent(l+i)) elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c' - if (IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value + if (IO_lc(IO_strValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value elemInCurrentSet = elemInCurrentSet + 1 ! data ended exit end if @@ -420,7 +420,7 @@ end subroutine inputRead_NelemSets subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,& fileContent) - character(len=pStringLen), dimension(:), allocatable, intent(out) :: nameElemSet + character(len=pSTRLEN), dimension(:), allocatable, intent(out) :: nameElemSet integer, dimension(:,:), allocatable, intent(out) :: mapElemSet character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines @@ -434,12 +434,12 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,& elemSet = 0 do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 2) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. & - IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'define' .and. & + IO_lc(IO_strValue(fileContent(l),chunkPos,2)) == 'element') then elemSet = elemSet+1 - nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4)) + nameElemSet(elemSet) = trim(IO_strValue(fileContent(l),chunkPos,4)) mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) end if end do @@ -465,17 +465,17 @@ subroutine inputRead_mapElems(FEM2DAMASK, & do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i = 1,nElems - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i+j),chunkPos,1),i] nNodesAlreadyRead = chunkPos(1) - 2 do while(nNodesAlreadyRead < nNodesPerElem) ! read on if not all nodes in one line j = j + 1 - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) end do end do @@ -509,9 +509,9 @@ subroutine inputRead_mapNodes(FEM2DAMASK, & do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'coordinates') then chunkPos = [1,1,10] do i = 1,nNodes map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i] @@ -546,9 +546,9 @@ subroutine inputRead_elemNodes(nodes, & allocate(nodes(3,nNode)) do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'coordinates') then chunkPos = [4,1,10,11,30,31,50,51,70] do i=1,nNode m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1)) @@ -577,23 +577,23 @@ subroutine inputRead_elemType(elem, & t = -1 do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i=1,nElem ! read all elements - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) if (t == -1) then - t = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2)) + t = mapElemtype(IO_strValue(fileContent(l+1+i+j),chunkPos,2)) call elem%init(t) else - t_ = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2)) - if (t /= t_) call IO_error(191,IO_stringValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t) + t_ = mapElemtype(IO_strValue(fileContent(l+1+i+j),chunkPos,2)) + if (t /= t_) call IO_error(191,IO_strValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t) end if remainingChunks = elem%nNodes - (chunkPos(1) - 2) do while(remainingChunks > 0) j = j + 1 - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) remainingChunks = remainingChunks - chunkPos(1) end do end do @@ -668,12 +668,12 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent) do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i = 1,nElem - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) e = discretization_Marc_FEM2DAMASK_elem(IO_intValue(fileContent(l+1+i+j),chunkPos,1)) if (e /= 0) then ! disregard non CP elems do k = 1,chunkPos(1)-2 @@ -683,7 +683,7 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent) nNodesAlreadyRead = chunkPos(1) - 2 do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line j = j + 1 - chunkPos = IO_stringPos(fileContent(l+1+i+j)) + chunkPos = IO_strPos(fileContent(l+1+i+j)) do k = 1,chunkPos(1) inputRead_connectivityElem(nNodesAlreadyRead+k,e) = & discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k)) @@ -725,17 +725,17 @@ subroutine inputRead_material(materialAt,& allocate(materialAt(nElem)) do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 2) cycle - if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. & - IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then + if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'initial' .and. & + IO_lc(IO_strValue(fileContent(l),chunkPos,2)) == 'state') then k = merge(2,1,initialcondTableStyle == 2) - chunkPos = IO_stringPos(fileContent(l+k)) + chunkPos = IO_strPos(fileContent(l+k)) sv = IO_IntValue(fileContent(l+k),chunkPos,1) ! # of state variable if (sv == 2) then ! state var 2 gives material ID m = 1 - chunkPos = IO_stringPos(fileContent(l+k+m)) - do while (scan(IO_stringValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is no Efloat value? + chunkPos = IO_strPos(fileContent(l+k+m)) + do while (scan(IO_strValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is no Efloat value? ID = nint(IO_realValue(fileContent(l+k+m),chunkPos,1)) if (initialcondTableStyle == 2) m = m + 2 contInts = continuousIntValues(fileContent(l+k+m+1:),nElem,nameElemSet,mapElemSet,size(nameElemSet)) ! get affected elements @@ -1156,12 +1156,12 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN) rangeGeneration = .false. do l = 1, size(fileContent) - chunkPos = IO_stringPos(fileContent(l)) + chunkPos = IO_strPos(fileContent(l)) if (chunkPos(1) < 1) then ! empty line exit - elseif (verify(IO_stringValue(fileContent(l),chunkPos,1),'0123456789') > 0) then ! a non-int, i.e. set name + elseif (verify(IO_strValue(fileContent(l),chunkPos,1),'0123456789') > 0) then ! a non-int, i.e. set name do i = 1, lookupMaxN ! loop over known set names - if (IO_stringValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name + if (IO_strValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name continuousIntValues = lookupMap(:,i) ! return resp. entity list exit end if @@ -1180,7 +1180,7 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN) continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,i) end do - if ( IO_lc(IO_stringValue(fileContent(l),chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value + if ( IO_lc(IO_strValue(fileContent(l),chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,chunkPos(1)) exit @@ -1202,7 +1202,7 @@ logical function containsRange(str,chunkPos) containsRange = .False. if (chunkPos(1) == 3) then - if (IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True. + if (IO_lc(IO_strValue(str,chunkPos,2)) == 'to') containsRange = .True. end if end function containsRange diff --git a/src/YAML_parse.f90 b/src/YAML_parse.f90 index 1581e8dc0..2e3702844 100644 --- a/src/YAML_parse.f90 +++ b/src/YAML_parse.f90 @@ -122,7 +122,7 @@ recursive function parse_flow(YAML_flow) result(node) d = s + scan(flow_string(s+1_pI64:),':',kind=pI64) e = d + find_end(flow_string(d+1_pI64:),'}') key = trim(adjustl(flow_string(s+1_pI64:d-1_pI64))) - if (quotedString(key)) key = key(2:len(key)-1) + if (quotedStr(key)) key = key(2:len(key)-1) myVal => parse_flow(flow_string(d+1_pI64:e-1_pI64)) ! parse items (recursively) select type (node) @@ -147,7 +147,7 @@ recursive function parse_flow(YAML_flow) result(node) allocate(tScalar::node) select type (node) class is (tScalar) - if (quotedString(flow_string)) then + if (quotedStr(flow_string)) then node = trim(adjustl(flow_string(2:len(flow_string)-1))) else node = trim(adjustl(flow_string)) @@ -191,21 +191,21 @@ end function find_end !-------------------------------------------------------------------------------------------------- ! @brief Check whether a string is enclosed with single or double quotes. !-------------------------------------------------------------------------------------------------- -logical function quotedString(line) +logical function quotedStr(line) character(len=*), intent(in) :: line - quotedString = .false. + quotedStr = .false. if (len(line) == 0) return if (scan(line(:1),IO_QUOTES) == 1) then - quotedString = .true. + quotedStr = .true. if (line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line) end if -end function quotedString +end function quotedStr #ifdef FYAML @@ -876,7 +876,7 @@ subroutine selfTest() if (indentDepth('a') /= 0) error stop 'indentDepth' if (indentDepth('x ') /= 0) error stop 'indentDepth' - if (.not. quotedString("'a'")) error stop 'quotedString' + if (.not. quotedStr("'a'")) error stop 'quotedStr' if ( isFlow(' a')) error stop 'isFLow' if (.not. isFlow('{')) error stop 'isFlow' @@ -1025,9 +1025,9 @@ subroutine selfTest() dct = '{a: 1, b: 2}' list => YAML_parse_str_asList(lst//IO_EOL) - if (list%asFormattedString() /= lst) error stop 'str_asList' + if (list%asFormattedStr() /= lst) error stop 'str_asList' dict => YAML_parse_str_asDict(dct//IO_EOL) - if (dict%asFormattedString() /= dct) error stop 'str_asDict' + if (dict%asFormattedStr() /= dct) error stop 'str_asDict' end block parse diff --git a/src/YAML_types.f90 b/src/YAML_types.f90 index 201dd1da0..a2cd6a472 100644 --- a/src/YAML_types.f90 +++ b/src/YAML_types.f90 @@ -18,8 +18,8 @@ module YAML_types integer :: & length = 0 contains - procedure(asFormattedString), deferred :: & - asFormattedString + procedure(asFormattedStr), deferred :: & + asFormattedStr procedure :: & asScalar => tNode_asScalar, & asList => tNode_asList, & @@ -31,11 +31,11 @@ module YAML_types value contains procedure :: & - asFormattedString => tScalar_asFormattedString, & - asReal => tScalar_asReal, & - asInt => tScalar_asInt, & - asBool => tScalar_asBool, & - asString => tScalar_asString + asFormattedStr => tScalar_asFormattedStr, & + asReal => tScalar_asReal, & + asInt => tScalar_asInt, & + asBool => tScalar_asBool, & + asStr => tScalar_asStr end type tScalar type, extends(tNode), public :: tList @@ -44,13 +44,13 @@ module YAML_types last => NULL() contains procedure :: & - asFormattedString => tList_asFormattedString, & + asFormattedStr => tList_asFormattedStr, & append => tList_append, & as1dReal => tList_as1dReal, & as2dReal => tList_as2dReal, & as1dInt => tList_as1dInt, & as1dBool => tList_as1dBool, & - as1dString => tList_as1dString, & + as1dStr => tList_as1dStr, & contains => tList_contains, & tList_get, & tList_get_scalar, & @@ -62,32 +62,32 @@ module YAML_types tList_get_as1dInt, & tList_get_asBool, & tList_get_as1dBool, & - tList_get_asString, & - tList_get_as1dString - generic :: get => tList_get - generic :: get_scalar => tList_get_scalar - generic :: get_list => tList_get_list - generic :: get_dict => tList_get_dict - generic :: get_asReal => tList_get_asReal - generic :: get_as1dReal => tList_get_as1dReal - generic :: get_asInt => tList_get_asInt - generic :: get_as1dInt => tList_get_as1dInt - generic :: get_asBool => tList_get_asBool - generic :: get_as1dBool => tList_get_as1dBool - generic :: get_asString => tList_get_asString - generic :: get_as1dString => tList_get_as1dString + tList_get_asStr, & + tList_get_as1dStr + generic :: get => tList_get + generic :: get_scalar => tList_get_scalar + generic :: get_list => tList_get_list + generic :: get_dict => tList_get_dict + generic :: get_asReal => tList_get_asReal + generic :: get_as1dReal => tList_get_as1dReal + generic :: get_asInt => tList_get_asInt + generic :: get_as1dInt => tList_get_as1dInt + generic :: get_asBool => tList_get_asBool + generic :: get_as1dBool => tList_get_as1dBool + generic :: get_asStr => tList_get_asStr + generic :: get_as1dStr => tList_get_as1dStr final :: tList_finalize end type tList type, extends(tList), public :: tDict contains procedure :: & - asFormattedString => tDict_asFormattedString, & - set => tDict_set, & - index => tDict_index, & - key => tDict_key, & - keys => tDict_keys, & - contains => tDict_contains, & + asFormattedStr => tDict_asFormattedStr, & + set => tDict_set, & + index => tDict_index, & + key => tDict_key, & + keys => tDict_keys, & + contains => tDict_contains, & tDict_get, & tDict_get_scalar, & tDict_get_list, & @@ -99,21 +99,21 @@ module YAML_types tDict_get_as1dInt, & tDict_get_asBool, & tDict_get_as1dBool, & - tDict_get_asString, & - tDict_get_as1dString - generic :: get => tDict_get - generic :: get_scalar => tDict_get_scalar - generic :: get_list => tDict_get_list - generic :: get_dict => tDict_get_dict - generic :: get_asReal => tDict_get_asReal - generic :: get_as1dReal => tDict_get_as1dReal - generic :: get_as2dReal => tDict_get_as2dReal - generic :: get_asInt => tDict_get_asInt - generic :: get_as1dInt => tDict_get_as1dInt - generic :: get_asBool => tDict_get_asBool - generic :: get_as1dBool => tDict_get_as1dBool - generic :: get_asString => tDict_get_asString - generic :: get_as1dString => tDict_get_as1dString + tDict_get_asStr, & + tDict_get_as1dStr + generic :: get => tDict_get + generic :: get_scalar => tDict_get_scalar + generic :: get_list => tDict_get_list + generic :: get_dict => tDict_get_dict + generic :: get_asReal => tDict_get_asReal + generic :: get_as1dReal => tDict_get_as1dReal + generic :: get_as2dReal => tDict_get_as2dReal + generic :: get_asInt => tDict_get_asInt + generic :: get_as1dInt => tDict_get_as1dInt + generic :: get_asBool => tDict_get_asBool + generic :: get_as1dBool => tDict_get_as1dBool + generic :: get_asStr => tDict_get_asStr + generic :: get_as1dStr => tDict_get_as1dStr end type tDict @@ -132,11 +132,11 @@ module YAML_types abstract interface - recursive function asFormattedString(self) + recursive function asFormattedStr(self) import tNode - character(len=:), allocatable :: asFormattedString + character(len=:), allocatable :: asFormattedStr class(tNode), intent(in), target :: self - end function asFormattedString + end function asFormattedStr end interface @@ -151,7 +151,7 @@ module YAML_types public :: & YAML_types_init, & #ifdef __GFORTRAN__ - output_as1dString, & !ToDo: Hack for GNU. Remove later + output_as1dStr, & !ToDo: Hack for GNU. Remove later #endif assignment(=) @@ -181,14 +181,14 @@ subroutine selfTest() s_pointer => s%asScalar() s = '1' - if (s%asInt() /= 1) error stop 'tScalar_asInt' - if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)' - if (dNeq(s%asReal(),1.0_pReal)) error stop 'tScalar_asReal' + if (s%asInt() /= 1) error stop 'tScalar_asInt' + if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)' + if (dNeq(s%asReal(),1.0_pReal)) error stop 'tScalar_asReal' s = 'true' - if (.not. s%asBool()) error stop 'tScalar_asBool' - if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)' - if (s%asString() /= 'true') error stop 'tScalar_asString' - if (s%asFormattedString() /= 'true') error stop 'tScalar_asFormattedString' + if (.not. s%asBool()) error stop 'tScalar_asBool' + if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)' + if (s%asStr() /= 'true') error stop 'tScalar_asStr' + if (s%asFormattedStr() /= 'true') error stop 'tScalar_asFormattedStr' end block scalar @@ -204,23 +204,23 @@ subroutine selfTest() s2 = '2' allocate(l) l_pointer => l%asList() - if (l%contains('1')) error stop 'empty tList_contains' - if (l_pointer%contains('1')) error stop 'empty tList_contains(pointer)' + if (l%contains('1')) error stop 'empty tList_contains' + if (l_pointer%contains('1')) error stop 'empty tList_contains(pointer)' call l%append(s1) call l%append(s2) - if (l%length /= 2) error stop 'tList%len' - if (dNeq(l%get_asReal(1),1.0_pReal)) error stop 'tList_get_asReal' - if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt' - if (l%get_asString(2) /= '2') error stop 'tList_get_asString' - if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt' - if (any(dNeq(l%as1dReal(),real([1.0,2.0],pReal)))) error stop 'tList_as1dReal' + if (l%length /= 2) error stop 'tList%len' + if (dNeq(l%get_asReal(1),1.0_pReal)) error stop 'tList_get_asReal' + if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt' + if (l%get_asStr(2) /= '2') error stop 'tList_get_asStr' + if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt' + if (any(dNeq(l%as1dReal(),real([1.0,2.0],pReal)))) error stop 'tList_as1dReal' s1 = 'true' s2 = 'false' - if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool' - if (any(l%as1dString() /= ['true ','false'])) error stop 'tList_as1dString' - if (l%asFormattedString() /= '[true, false]') error stop 'tList_asFormattedString' + if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool' + if (any(l%as1dStr() /= ['true ','false'])) error stop 'tList_as1dStr' + if (l%asFormattedStr() /= '[true, false]') error stop 'tList_asFormattedStr' if ( .not. l%contains('true') & - .or. .not. l%contains('false')) error stop 'tList_contains' + .or. .not. l%contains('false')) error stop 'tList_contains' end block list @@ -244,25 +244,25 @@ subroutine selfTest() s4 = '4' allocate(d) d_pointer => d%asDict() - if (d%contains('one-two')) error stop 'empty tDict_contains' - if (d_pointer%contains('one-two')) error stop 'empty tDict_contains(pointer)' - if (d%get_asInt('one-two',defaultVal=-1) /= -1) error stop 'empty tDict_get' + if (d%contains('one-two')) error stop 'empty tDict_contains' + if (d_pointer%contains('one-two')) error stop 'empty tDict_contains(pointer)' + if (d%get_asInt('one-two',defaultVal=-1) /= -1) error stop 'empty tDict_get' call d%set('one-two',l) call d%set('three',s3) call d%set('four',s4) - if (d%asFormattedString() /= '{one-two: [1, 2], three: 3, four: 4}') & - error stop 'tDict_asFormattedString' - if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt' - if (dNeq(d%get_asReal('three'),3.0_pReal)) error stop 'tDict_get_asReal' - if (d%get_asString('three') /= '3') error stop 'tDict_get_asString' - if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt' + if (d%asFormattedStr() /= '{one-two: [1, 2], three: 3, four: 4}') & + error stop 'tDict_asFormattedStr' + if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt' + if (dNeq(d%get_asReal('three'),3.0_pReal)) error stop 'tDict_get_asReal' + if (d%get_asStr('three') /= '3') error stop 'tDict_get_asStr' + if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt' call d%set('one-two',s4) - if (d%asFormattedString() /= '{one-two: 4, three: 3, four: 4}') & - error stop 'tDict_set overwrite' + if (d%asFormattedStr() /= '{one-two: 4, three: 3, four: 4}') & + error stop 'tDict_set overwrite' if ( .not. d%contains('one-two') & .or. .not. d%contains('three') & .or. .not. d%contains('four') & - ) error stop 'tDict_contains' + ) error stop 'tDict_contains' end block dict @@ -299,7 +299,7 @@ end subroutine tScalar_assign__ !-------------------------------------------------------------------------------------------------- !> @brief Format as string (YAML flow style). !-------------------------------------------------------------------------------------------------- -recursive function tScalar_asFormattedString(self) result(str) +recursive function tScalar_asFormattedStr(self) result(str) class (tScalar), intent(in), target :: self character(len=:), allocatable :: str @@ -307,7 +307,7 @@ recursive function tScalar_asFormattedString(self) result(str) str = trim(self%value) -end function tScalar_asFormattedString +end function tScalar_asFormattedStr !-------------------------------------------------------------------------------------------------- @@ -324,7 +324,7 @@ function tNode_asScalar(self) result(scalar) scalar => self class default nullify(scalar) - call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a scalar') + call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a scalar') end select end function tNode_asScalar @@ -344,7 +344,7 @@ function tNode_asList(self) result(list) list => self class default nullify(list) - call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a list') + call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a list') end select end function tNode_asList @@ -364,7 +364,7 @@ function tNode_asDict(self) result(dict) dict => self class default nullify(dict) - call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a dict') + call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a dict') end select end function tNode_asDict @@ -379,7 +379,7 @@ function tScalar_asReal(self) real(pReal) :: tScalar_asReal - tScalar_asReal = IO_stringAsReal(self%value) + tScalar_asReal = IO_strAsReal(self%value) end function tScalar_asReal @@ -393,7 +393,7 @@ function tScalar_asInt(self) integer :: tScalar_asInt - tScalar_asInt = IO_stringAsInt(self%value) + tScalar_asInt = IO_strAsInt(self%value) end function tScalar_asInt @@ -407,7 +407,7 @@ function tScalar_asBool(self) logical :: tScalar_asBool - tScalar_asBool = IO_stringAsBool(self%value) + tScalar_asBool = IO_strAsBool(self%value) end function tScalar_asBool @@ -415,21 +415,21 @@ end function tScalar_asBool !-------------------------------------------------------------------------------------------------- !> @brief Convert to string. !-------------------------------------------------------------------------------------------------- -function tScalar_asString(self) +function tScalar_asStr(self) class(tScalar), intent(in), target :: self - character(len=:), allocatable :: tScalar_asString + character(len=:), allocatable :: tScalar_asStr - tScalar_asString = self%value + tScalar_asStr = self%value -end function tScalar_asString +end function tScalar_asStr !-------------------------------------------------------------------------------------------------- !> @brief Format as string (YAML flow style). !-------------------------------------------------------------------------------------------------- -recursive function tList_asFormattedString(self) result(str) +recursive function tList_asFormattedStr(self) result(str) class(tList),intent(in),target :: self @@ -440,12 +440,12 @@ recursive function tList_asFormattedString(self) result(str) str = '[' item => self%first do i = 2, self%length - str = str//item%node%asFormattedString()//', ' + str = str//item%node%asFormattedStr()//', ' item => item%next end do - str = str//item%node%asFormattedString()//']' + str = str//item%node%asFormattedStr()//']' -end function tList_asFormattedString +end function tList_asFormattedStr !-------------------------------------------------------------------------------------------------- @@ -574,13 +574,13 @@ end function tList_as1dBool !-------------------------------------------------------------------------------------------------- !> @brief Convert to string array (1D). !-------------------------------------------------------------------------------------------------- -function tList_as1dString(self) +function tList_as1dStr(self) class(tList), intent(in), target :: self #ifdef __GFORTRAN__ - character(len=pStringLen), allocatable, dimension(:) :: tList_as1dString + character(len=pSTRLEN), allocatable, dimension(:) :: tList_as1dStr #else - character(len=:), allocatable, dimension(:) :: tList_as1dString + character(len=:), allocatable, dimension(:) :: tList_as1dStr #endif integer :: j @@ -589,27 +589,27 @@ function tList_as1dString(self) #ifdef __GFORTRAN__ - allocate(tList_as1dString(self%length)) + allocate(tList_as1dStr(self%length)) #else integer :: len_max len_max = 0 item => self%first do j = 1, self%length scalar => item%node%asScalar() - len_max = max(len_max, len_trim(scalar%asString())) + len_max = max(len_max, len_trim(scalar%asStr())) item => item%next end do - allocate(character(len=len_max) :: tList_as1dString(self%length)) + allocate(character(len=len_max) :: tList_as1dStr(self%length)) #endif item => self%first do j = 1, self%length scalar => item%node%asScalar() - tList_as1dString(j) = scalar%asString() + tList_as1dStr(j) = scalar%asStr() item => item%next end do -end function tList_as1dString +end function tList_as1dStr !------------------------------------------------------------------------------------------------- @@ -652,8 +652,8 @@ function tList_get(self,i) result(node) integer :: j - if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tList_get @ '//IO_intAsString(i) & - //' of '//IO_intAsString(self%length) ) + if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tList_get @ '//IO_intAsStr(i) & + //' of '//IO_intAsStr(self%length) ) item => self%first do j = 2, i item => item%next @@ -828,37 +828,37 @@ end function tList_get_as1dBool !-------------------------------------------------------------------------------------------------- !> @brief Get scalar by index and convert to string. !-------------------------------------------------------------------------------------------------- -function tList_get_asString(self,i) result(nodeAsString) +function tList_get_asStr(self,i) result(nodeAsStr) class(tList), intent(in) :: self integer, intent(in) :: i - character(len=:), allocatable :: nodeAsString + character(len=:), allocatable :: nodeAsStr class(tScalar), pointer :: scalar scalar => self%get_scalar(i) - nodeAsString = scalar%asString() + nodeAsStr = scalar%asStr() -end function tList_get_asString +end function tList_get_asStr !-------------------------------------------------------------------------------------------------- !> @brief Get list by index and convert to string array (1D). !-------------------------------------------------------------------------------------------------- -function tList_get_as1dString(self,i) result(nodeAs1dString) +function tList_get_as1dStr(self,i) result(nodeAs1dStr) class(tList), intent(in) :: self integer, intent(in) :: i - character(len=:), allocatable, dimension(:) :: nodeAs1dString + character(len=:), allocatable, dimension(:) :: nodeAs1dStr type(tList), pointer :: list list => self%get_list(i) - nodeAs1dString = list%as1dString() + nodeAs1dStr = list%as1dStr() -end function tList_get_as1dString +end function tList_get_as1dStr !-------------------------------------------------------------------------------------------------- @@ -876,7 +876,7 @@ end subroutine tList_finalize !-------------------------------------------------------------------------------------------------- !> @brief Format as string (YAML flow style). !-------------------------------------------------------------------------------------------------- -recursive function tDict_asFormattedString(self) result(str) +recursive function tDict_asFormattedStr(self) result(str) class(tDict),intent(in),target :: self @@ -888,12 +888,12 @@ recursive function tDict_asFormattedString(self) result(str) str = '{' item => self%first do i = 2, self%length - str = str//trim(item%key)//': '//item%node%asFormattedString()//', ' + str = str//trim(item%key)//': '//item%node%asFormattedStr()//', ' item => item%next end do - str = str//trim(item%key)//': '//item%node%asFormattedString()//'}' + str = str//trim(item%key)//': '//item%node%asFormattedStr()//'}' -end function tDict_asFormattedString +end function tDict_asFormattedStr !-------------------------------------------------------------------------------------------------- @@ -967,8 +967,8 @@ function tDict_key(self,i) result(key) type(tItem), pointer :: item - if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tDict_key @ '//IO_intAsString(i) & - //' of '//IO_intAsString(self%length) ) + if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tDict_key @ '//IO_intAsStr(i) & + //' of '//IO_intAsStr(self%length) ) item => self%first do j = 2, i item => item%next @@ -987,7 +987,7 @@ function tDict_keys(self) result(keys) class(tDict), intent(in) :: self character(len=:), dimension(:), allocatable :: keys - character(len=pStringLen), dimension(:), allocatable :: temp + character(len=pSTRLEN), dimension(:), allocatable :: temp integer :: j, l @@ -1310,61 +1310,61 @@ end function tDict_get_as1dBool !-------------------------------------------------------------------------------------------------- !> @brief Get scalar by key and convert to string. !-------------------------------------------------------------------------------------------------- -function tDict_get_asString(self,k,defaultVal) result(nodeAsString) +function tDict_get_asStr(self,k,defaultVal) result(nodeAsStr) class(tDict), intent(in) :: self character(len=*), intent(in) :: k character(len=*), intent(in), optional :: defaultVal - character(len=:), allocatable :: nodeAsString + character(len=:), allocatable :: nodeAsStr type(tScalar), pointer :: scalar if (self%contains(k)) then scalar => self%get_scalar(k) - nodeAsString = scalar%asString() + nodeAsStr = scalar%asStr() elseif (present(defaultVal)) then - nodeAsString = defaultVal + nodeAsStr = defaultVal else call IO_error(143,ext_msg=k) end if -end function tDict_get_asString +end function tDict_get_asStr !-------------------------------------------------------------------------------------------------- !> @brief Get list by key and convert to string array (1D). !-------------------------------------------------------------------------------------------------- -function tDict_get_as1dString(self,k,defaultVal) result(nodeAs1dString) +function tDict_get_as1dStr(self,k,defaultVal) result(nodeAs1dStr) class(tDict), intent(in) :: self character(len=*), intent(in) :: k character(len=*), intent(in), dimension(:), optional :: defaultVal - character(len=:), allocatable, dimension(:) :: nodeAs1dString + character(len=:), allocatable, dimension(:) :: nodeAs1dStr type(tList), pointer :: list if (self%contains(k)) then list => self%get_list(k) - nodeAs1dString = list%as1dString() + nodeAs1dStr = list%as1dStr() elseif (present(defaultVal)) then - nodeAs1dString = defaultVal + nodeAs1dStr = defaultVal else call IO_error(143,ext_msg=k) end if -end function tDict_get_as1dString +end function tDict_get_as1dStr #ifdef __GFORTRAN__ !-------------------------------------------------------------------------------------------------- !> @brief Returns string output array (1D) (hack for GNU). !-------------------------------------------------------------------------------------------------- -function output_as1dString(self) result(output) +function output_as1dStr(self) result(output) class(tDict), pointer,intent(in) :: self - character(len=pStringLen), allocatable, dimension(:) :: output + character(len=pSTRLEN), allocatable, dimension(:) :: output type(tList), pointer :: output_list integer :: o @@ -1372,10 +1372,10 @@ function output_as1dString(self) result(output) output_list => self%get_list('output',defaultVal=emptyList) allocate(output(output_list%length)) do o = 1, output_list%length - output(o) = output_list%get_asString(o) + output(o) = output_list%get_asStr(o) end do -end function output_as1dString +end function output_as1dStr #endif diff --git a/src/config.f90 b/src/config.f90 index e5f9011fb..6e173db57 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -83,7 +83,7 @@ function config_listReferences(config,indent) result(references) else references = 'references:' do r = 1, ref%length - references = references//IO_EOL//filler//'- '//IO_wrapLines(ref%get_asString(r),filler=filler//' ') + references = references//IO_EOL//filler//'- '//IO_wrapLines(ref%get_asStr(r),filler=filler//' ') end do end if diff --git a/src/grid/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 index 84cd94e45..0fccdf548 100644 --- a/src/grid/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -88,7 +88,7 @@ program DAMASK_grid maxCutBack, & !< max number of cut backs stagItMax !< max number of field level staggered iterations integer(MPI_INTEGER_KIND) :: err_MPI - character(len=pStringLen) :: & + character(len=pSTRLEN) :: & incInfo type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases @@ -158,7 +158,7 @@ program DAMASK_grid ! assign mechanics solver depending on selected type nActiveFields = 1 - select case (solver%get_asString('mechanical')) + select case (solver%get_asStr('mechanical')) case ('spectral_basic') mechanical_init => grid_mechanical_spectral_basic_init mechanical_forward => grid_mechanical_spectral_basic_forward @@ -181,25 +181,25 @@ program DAMASK_grid mechanical_restartWrite => grid_mechanical_FEM_restartWrite case default - call IO_error(error_ID = 891, ext_msg = trim(solver%get_asString('mechanical'))) + call IO_error(error_ID = 891, ext_msg = trim(solver%get_asStr('mechanical'))) end select !-------------------------------------------------------------------------------------------------- ! initialize field solver information - if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1 - if (solver%get_asString('damage', defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1 + if (solver%get_asStr('thermal',defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1 + if (solver%get_asStr('damage', defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1 allocate(solres(nActiveFields)) allocate( ID(nActiveFields)) field = 1 ID(field) = FIELD_MECH_ID ! mechanical active by default - thermalActive: if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') then + thermalActive: if (solver%get_asStr('thermal',defaultVal = 'n/a') == 'spectral') then field = field + 1 ID(field) = FIELD_THERMAL_ID end if thermalActive - damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then + damageActive: if (solver%get_asStr('damage',defaultVal = 'n/a') == 'spectral') then field = field + 1 ID(field) = FIELD_DAMAGE_ID end if damageActive @@ -244,7 +244,7 @@ program DAMASK_grid loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pReal) loadCases(l)%f_restart = load_step%get_asInt('f_restart', defaultVal=huge(0)) - if (load_step%get_asString('f_out',defaultVal='n/a') == 'none') then + if (load_step%get_asStr('f_out',defaultVal='n/a') == 'none') then loadCases(l)%f_out = huge(0) else loadCases(l)%f_out = load_step%get_asInt('f_out', defaultVal=1) @@ -525,7 +525,7 @@ subroutine getMaskedTensor(values,mask,tensor) do i = 1,3 row => tensor%get_list(i) do j = 1,3 - mask(i,j) = row%get_asString(j) == 'x' + mask(i,j) = row%get_asStr(j) == 'x' if (.not. mask(i,j)) values(i,j) = row%get_asReal(j) end do end do diff --git a/src/grid/VTI.f90 b/src/grid/VTI.f90 index ebc162ca9..ca166c042 100644 --- a/src/grid/VTI.f90 +++ b/src/grid/VTI.f90 @@ -211,16 +211,16 @@ subroutine cellsSizeOrigin(c,s,o,header) call IO_error(error_ID = 844, ext_msg = 'coordinate order') temp = getXMLValue(header,'WholeExtent') - if (any([(IO_intValue(temp,IO_stringPos(temp),i),i=1,5,2)] /= 0)) & + if (any([(IO_intValue(temp,IO_strPos(temp),i),i=1,5,2)] /= 0)) & call IO_error(error_ID = 844, ext_msg = 'coordinate start') - c = [(IO_intValue(temp,IO_stringPos(temp),i),i=2,6,2)] + c = [(IO_intValue(temp,IO_strPos(temp),i),i=2,6,2)] temp = getXMLValue(header,'Spacing') - delta = [(IO_realValue(temp,IO_stringPos(temp),i),i=1,3)] + delta = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] s = delta * real(c,pReal) temp = getXMLValue(header,'Origin') - o = [(IO_realValue(temp,IO_stringPos(temp),i),i=1,3)] + o = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] end subroutine cellsSizeOrigin diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index 2c5ac0f16..0e0e36f3e 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -84,7 +84,7 @@ subroutine grid_damage_spectral_init() type(tDict), pointer :: & num_grid, & num_generic - character(len=pStringLen) :: & + character(len=pSTRLEN) :: & snes_type print'(/,1x,a)', '<<<+- grid_spectral_damage init -+>>>' @@ -114,7 +114,7 @@ subroutine grid_damage_spectral_init() call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-damage_snes_type newtonls -damage_snes_mf & &-damage_snes_ksp_ew -damage_ksp_type fgmres',err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index 366504caa..70809f2d1 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -119,7 +119,7 @@ subroutine grid_mechanical_FEM_init integer(HID_T) :: fileHandle, groupHandle type(tDict), pointer :: & num_grid - character(len=pStringLen) :: & + character(len=pSTRLEN) :: & extmsg = '' @@ -152,7 +152,7 @@ subroutine grid_mechanical_FEM_init &-mechanical_ksp_max_it 25', & err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 index 6c423d51a..ac1fa1134 100644 --- a/src/grid/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -115,7 +115,7 @@ subroutine grid_mechanical_spectral_basic_init() integer(HID_T) :: fileHandle, groupHandle type(tDict), pointer :: & num_grid - character(len=pStringLen) :: & + character(len=pSTRLEN) :: & extmsg = '' @@ -152,7 +152,7 @@ subroutine grid_mechanical_spectral_basic_init() ! set default and user defined options for PETSc call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type ngmres',err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 index 0b086508f..0cdb3a5e1 100644 --- a/src/grid/grid_mech_spectral_polarisation.f90 +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -128,7 +128,7 @@ subroutine grid_mechanical_spectral_polarisation_init() integer(HID_T) :: fileHandle, groupHandle type(tDict), pointer :: & num_grid - character(len=pStringLen) :: & + character(len=pSTRLEN) :: & extmsg = '' @@ -171,7 +171,7 @@ subroutine grid_mechanical_spectral_polarisation_init() ! set default and user defined options for PETSc call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type ngmres',err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index e79a5d49e..bfc5ccb5f 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -105,7 +105,7 @@ subroutine grid_thermal_spectral_init() call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-thermal_snes_type newtonls -thermal_snes_mf & &-thermal_snes_ksp_ew -thermal_ksp_type fgmres',err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index 3a4b4c092..0d6b71963 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -168,7 +168,7 @@ subroutine spectral_utilities_init() call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc) CHKERRQ(err_PETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,& - num_grid%get_asString('PETSc_options',defaultVal=''),err_PETSc) + num_grid%get_asStr('PETSc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) cells1Red = cells(1)/2 + 1 @@ -180,7 +180,7 @@ subroutine spectral_utilities_init() if (num%divergence_correction < 0 .or. num%divergence_correction > 2) & call IO_error(301,ext_msg='divergence_correction') - select case (num_grid%get_asString('derivative',defaultVal='continuous')) + select case (num_grid%get_asStr('derivative',defaultVal='continuous')) case ('continuous') spectral_derivative_ID = DERIVATIVE_CONTINUOUS_ID case ('central_difference') @@ -188,7 +188,7 @@ subroutine spectral_utilities_init() case ('FWBW_difference') spectral_derivative_ID = DERIVATIVE_FWBW_DIFF_ID case default - call IO_error(892,ext_msg=trim(num_grid%get_asString('derivative'))) + call IO_error(892,ext_msg=trim(num_grid%get_asStr('derivative'))) end select !-------------------------------------------------------------------------------------------------- @@ -209,7 +209,7 @@ subroutine spectral_utilities_init() scaledGeomSize = geomSize end if - select case(IO_lc(num_grid%get_asString('fftw_plan_mode',defaultVal='FFTW_MEASURE'))) + select case(IO_lc(num_grid%get_asStr('fftw_plan_mode',defaultVal='FFTW_MEASURE'))) case('fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution FFTW_planner_flag = FFTW_ESTIMATE case('fftw_measure') @@ -219,7 +219,7 @@ subroutine spectral_utilities_init() case('fftw_exhaustive') FFTW_planner_flag = FFTW_EXHAUSTIVE case default - call IO_warning(47,'using default FFTW_MEASURE instead of "'//trim(num_grid%get_asString('fftw_plan_mode'))//'"') + call IO_warning(47,'using default FFTW_MEASURE instead of "'//trim(num_grid%get_asStr('fftw_plan_mode'))//'"') FFTW_planner_flag = FFTW_MEASURE end select @@ -655,7 +655,7 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C) c_reduced, & !< reduced stiffness (depending on number of stress BC) sTimesC !< temp variable to check inversion logical :: errmatinv - character(len=pStringLen):: formatString + character(len=pSTRLEN):: formatString mask_stressVector = .not. reshape(transpose(mask_stress), [9]) size_reduced = count(mask_stressVector) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 778a094b4..d4c9e0941 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -482,7 +482,7 @@ subroutine parseHomogenization if (homog%contains('thermal')) then homogThermal => homog%get_dict('thermal') - select case (homogThermal%get_asString('type')) + select case (homogThermal%get_asStr('type')) case('pass') thermal_type(h) = THERMAL_PASS_ID thermal_active(h) = .true. @@ -490,17 +490,17 @@ subroutine parseHomogenization thermal_type(h) = THERMAL_ISOTEMPERATURE_ID thermal_active(h) = .true. case default - call IO_error(500,ext_msg=homogThermal%get_asString('type')) + call IO_error(500,ext_msg=homogThermal%get_asStr('type')) end select end if if (homog%contains('damage')) then homogDamage => homog%get_dict('damage') - select case (homogDamage%get_asString('type')) + select case (homogDamage%get_asStr('type')) case('pass') damage_active(h) = .true. case default - call IO_error(500,ext_msg=homogDamage%get_asString('type')) + call IO_error(500,ext_msg=homogDamage%get_asStr('type')) end select end if end do diff --git a/src/homogenization_damage.f90 b/src/homogenization_damage.f90 index 703f546d0..7de304abc 100644 --- a/src/homogenization_damage.f90 +++ b/src/homogenization_damage.f90 @@ -17,7 +17,7 @@ submodule(homogenization) damage type(tDataContainer), dimension(:), allocatable :: current type :: tParameters - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -54,15 +54,15 @@ module subroutine damage_init() if (configHomogenization%contains('damage')) then configHomogenizationDamage => configHomogenization%get_dict('damage') #if defined (__GFORTRAN__) - prm%output = output_as1dString(configHomogenizationDamage) + prm%output = output_as1dStr(configHomogenizationDamage) #else - prm%output = configHomogenizationDamage%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = configHomogenizationDamage%get_as1dStr('output',defaultVal=emptyStrArray) #endif damageState_h(ho)%sizeState = 1 allocate(damageState_h(ho)%state0(1,Nmembers), source=1.0_pReal) allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pReal) else - prm%output = emptyStringArray + prm%output = emptyStrArray end if end associate end do diff --git a/src/homogenization_mechanical.f90 b/src/homogenization_mechanical.f90 index 24625769e..2493bbb3c 100644 --- a/src/homogenization_mechanical.f90 +++ b/src/homogenization_mechanical.f90 @@ -51,7 +51,7 @@ submodule(homogenization) mechanical end interface type :: tOutput !< requested output (per phase) - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & label end type tOutput type(tOutput), allocatable, dimension(:) :: output_mechanical @@ -63,7 +63,7 @@ submodule(homogenization) mechanical MECHANICAL_RGC_ID end enum integer(kind(MECHANICAL_UNDEFINED_ID)), dimension(:), allocatable :: & - mechanical_type !< type of each homogenization + mechanical_type !< type of each homogenization contains @@ -239,11 +239,11 @@ subroutine parseMechanical() homog => material_homogenization%get_dict(ho) mechanical => homog%get_dict('mechanical') #if defined(__GFORTRAN__) - output_mechanical(ho)%label = output_as1dString(mechanical) + output_mechanical(ho)%label = output_as1dStr(mechanical) #else - output_mechanical(ho)%label = mechanical%get_as1dString('output',defaultVal=emptyStringArray) + output_mechanical(ho)%label = mechanical%get_as1dStr('output',defaultVal=emptyStrArray) #endif - select case (mechanical%get_asString('type')) + select case (mechanical%get_asStr('type')) case('pass') mechanical_type(ho) = MECHANICAL_PASS_ID case('isostrain') @@ -251,7 +251,7 @@ subroutine parseMechanical() case('RGC') mechanical_type(ho) = MECHANICAL_RGC_ID case default - call IO_error(500,ext_msg=mechanical%get_asString('type')) + call IO_error(500,ext_msg=mechanical%get_asStr('type')) end select end do diff --git a/src/homogenization_mechanical_RGC.f90 b/src/homogenization_mechanical_RGC.f90 index eff8a400e..dba513ced 100644 --- a/src/homogenization_mechanical_RGC.f90 +++ b/src/homogenization_mechanical_RGC.f90 @@ -19,7 +19,7 @@ submodule(homogenization:mechanical) RGC real(pReal), dimension(:), allocatable :: & D_alpha, & a_g - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -147,9 +147,9 @@ module subroutine RGC_init() dst => dependentState(ho)) #if defined (__GFORTRAN__) - prm%output = output_as1dString(homogMech) + prm%output = output_as1dStr(homogMech) #else - prm%output = homogMech%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = homogMech%get_as1dStr('output',defaultVal=emptyStrArray) #endif prm%N_constituents = homogMech%get_as1dInt('cluster_size',requiredSize=3) diff --git a/src/homogenization_thermal.f90 b/src/homogenization_thermal.f90 index edba596c8..27dc57db4 100644 --- a/src/homogenization_thermal.f90 +++ b/src/homogenization_thermal.f90 @@ -20,7 +20,7 @@ submodule(homogenization) thermal type(tDataContainer), dimension(:), allocatable :: current type :: tParameters - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -58,11 +58,11 @@ module subroutine thermal_init() if (configHomogenization%contains('thermal')) then configHomogenizationThermal => configHomogenization%get_dict('thermal') #if defined (__GFORTRAN__) - prm%output = output_as1dString(configHomogenizationThermal) + prm%output = output_as1dStr(configHomogenizationThermal) #else - prm%output = configHomogenizationThermal%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = configHomogenizationThermal%get_as1dStr('output',defaultVal=emptyStrArray) #endif - select case (configHomogenizationThermal%get_asString('type')) + select case (configHomogenizationThermal%get_asStr('type')) case ('pass') call pass_init() @@ -72,7 +72,7 @@ module subroutine thermal_init() end select else - prm%output = emptyStringArray + prm%output = emptyStrArray end if end associate diff --git a/src/material.f90 b/src/material.f90 index a2e2a90aa..beeda8e42 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -138,7 +138,7 @@ subroutine parse() item => materials%first do ma = 1, materials%length material => item%node%asDict() - ho_of(ma) = homogenizations%index(material%get_asString('homogenization')) + ho_of(ma) = homogenizations%index(material%get_asStr('homogenization')) constituents => material%get_list('constituents') homogenization => homogenizations%get_dict(ho_of(ma)) @@ -150,7 +150,7 @@ subroutine parse() do co = 1, constituents%length constituent => constituents%get_dict(co) v_of(ma,co) = constituent%get_asReal('v') - ph_of(ma,co) = phases%index(constituent%get_asString('phase')) + ph_of(ma,co) = phases%index(constituent%get_asStr('phase')) call material_O_0(ma)%data(co)%fromQuaternion(constituent%get_as1dReal('O',requiredSize=4)) material_V_e_0(ma)%data(1:3,1:3,co) = constituent%get_as2dReal('V_e',defaultVal=math_I3,requiredShape=[3,3]) @@ -212,8 +212,8 @@ end subroutine parse function getKeys(dict) type(tDict), intent(in) :: dict - character(len=:), dimension(:), allocatable :: getKeys - character(len=pStringLen), dimension(:), allocatable :: temp + character(len=:), dimension(:), allocatable :: getKeys + character(len=pSTRLEN), dimension(:), allocatable :: temp integer :: i,l diff --git a/src/mesh/DAMASK_mesh.f90 b/src/mesh/DAMASK_mesh.f90 index a958e2f04..1294edd99 100644 --- a/src/mesh/DAMASK_mesh.f90 +++ b/src/mesh/DAMASK_mesh.f90 @@ -67,8 +67,8 @@ program DAMASK_mesh component type(tDict), pointer :: & num_mesh - character(len=pStringLen), dimension(:), allocatable :: fileContent - character(len=pStringLen) :: & + character(len=pSTRLEN), dimension(:), allocatable :: fileContent + character(len=pSTRLEN) :: & incInfo, & loadcase_string integer :: & @@ -109,9 +109,9 @@ program DAMASK_mesh line = fileContent(l) if (IO_isBlank(line)) cycle ! skip empty lines - chunkPos = IO_stringPos(line) + chunkPos = IO_strPos(line) do i = 1, chunkPos(1) ! reading compulsory parameters for loadcase - select case (IO_stringValue(line,chunkPos,i)) + select case (IO_strValue(line,chunkPos,i)) case('$Loadcase') N_def = N_def + 1 end select @@ -151,9 +151,9 @@ program DAMASK_mesh line = fileContent(l) if (IO_isBlank(line)) cycle ! skip empty lines - chunkPos = IO_stringPos(line) + chunkPos = IO_strPos(line) do i = 1, chunkPos(1) - select case (IO_stringValue(line,chunkPos,i)) + select case (IO_strValue(line,chunkPos,i)) !-------------------------------------------------------------------------------------------------- ! loadcase information case('$Loadcase') @@ -177,7 +177,7 @@ program DAMASK_mesh !-------------------------------------------------------------------------------------------------- ! boundary condition information case('X','Y','Z') - select case(IO_stringValue(line,chunkPos,i)) + select case(IO_strValue(line,chunkPos,i)) case('X') ID = COMPONENT_MECH_X_ID case('Y') diff --git a/src/mesh/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 index 6fc3b4f61..2eab945d9 100644 --- a/src/mesh/FEM_utilities.f90 +++ b/src/mesh/FEM_utilities.f90 @@ -92,7 +92,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine FEM_utilities_init - character(len=pStringLen) :: petsc_optionsOrder + character(len=pSTRLEN) :: petsc_optionsOrder type(tDict), pointer :: & num_mesh integer :: & @@ -122,7 +122,7 @@ subroutine FEM_utilities_init &-mechanical_snes_ksp_ew_rtol0 0.01 -mechanical_snes_ksp_ew_rtolmax 0.01 & &-mechanical_ksp_type fgmres -mechanical_ksp_max_it 25', err_PETSc) CHKERRQ(err_PETSc) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_mesh%get_asString('PETSc_options',defaultVal=''),err_PETSc) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_mesh%get_asStr('PETSc_options',defaultVal=''),err_PETSc) CHKERRQ(err_PETSc) write(petsc_optionsOrder,'(a,i0)') '-mechFE_petscspace_degree ', p_s call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),err_PETSc) diff --git a/src/mesh/mesh_mech_FEM.f90 b/src/mesh/mesh_mech_FEM.f90 index 16fe24e19..930299a67 100644 --- a/src/mesh/mesh_mech_FEM.f90 +++ b/src/mesh/mesh_mech_FEM.f90 @@ -65,7 +65,7 @@ module mesh_mechanical_FEM !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - character(len=pStringLen) :: incInfo + character(len=pSTRLEN) :: incInfo real(pReal), dimension(3,3) :: & P_av = 0.0_pReal logical :: ForwardData diff --git a/src/misc.f90 b/src/misc.f90 index b3be4de14..b4936b070 100644 --- a/src/misc.f90 +++ b/src/misc.f90 @@ -13,7 +13,7 @@ module misc module procedure misc_optional_bool module procedure misc_optional_integer module procedure misc_optional_real - module procedure misc_optional_string + module procedure misc_optional_str end interface misc_optional public :: & @@ -95,7 +95,7 @@ end function misc_optional_real !-------------------------------------------------------------------------------------------------- !> @brief Return string value if given, otherwise default. !-------------------------------------------------------------------------------------------------- -pure function misc_optional_string(given,default) result(var) +pure function misc_optional_str(given,default) result(var) character(len=*), intent(in), optional :: given character(len=*), intent(in) :: default @@ -108,7 +108,7 @@ pure function misc_optional_string(given,default) result(var) var = default end if -end function misc_optional_string +end function misc_optional_str !-------------------------------------------------------------------------------------------------- @@ -119,9 +119,9 @@ subroutine misc_selfTest() real(pReal) :: r call random_number(r) - if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_string, present' - if (test_str() /= 'default') error stop 'optional_string, not present' - if (misc_optional(default='default') /= 'default') error stop 'optional_string, default only' + if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_str, present' + if (test_str() /= 'default') error stop 'optional_str, not present' + if (misc_optional(default='default') /= 'default') error stop 'optional_str, default only' if (test_int(20191102) /= 20191102) error stop 'optional_int, present' if (test_int() /= 42) error stop 'optional_int, not present' if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only' @@ -140,7 +140,7 @@ contains character(len=*), intent(in), optional :: str_in - str_out = misc_optional_string(str_in,'default') + str_out = misc_optional_str(str_in,'default') end function test_str diff --git a/src/parallelization.f90 b/src/parallelization.f90 index 6bca36c2a..b5f3daae8 100644 --- a/src/parallelization.f90 +++ b/src/parallelization.f90 @@ -39,8 +39,8 @@ module parallelization public :: parallelization_bcast_str contains -subroutine parallelization_bcast_str(string) - character(len=:), allocatable, intent(inout) :: string +subroutine parallelization_bcast_str(str) + character(len=:), allocatable, intent(inout) :: str end subroutine parallelization_bcast_str #else @@ -171,18 +171,18 @@ end subroutine parallelization_chkerr !-------------------------------------------------------------------------------------------------- !> @brief Broadcast a string from process 0. !-------------------------------------------------------------------------------------------------- -subroutine parallelization_bcast_str(string) +subroutine parallelization_bcast_str(str) - character(len=:), allocatable, intent(inout) :: string + character(len=:), allocatable, intent(inout) :: str integer(MPI_INTEGER_KIND) :: strlen, err_MPI - if (worldrank == 0) strlen = len(string,MPI_INTEGER_KIND) + if (worldrank == 0) strlen = len(str,MPI_INTEGER_KIND) call MPI_Bcast(strlen,1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI) - if (worldrank /= 0) allocate(character(len=strlen)::string) + if (worldrank /= 0) allocate(character(len=strlen)::str) - call MPI_Bcast(string,strlen,MPI_CHARACTER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI) + call MPI_Bcast(str,strlen,MPI_CHARACTER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI) end subroutine parallelization_bcast_str diff --git a/src/phase.f90 b/src/phase.f90 index 005d36660..6162b6c0a 100644 --- a/src/phase.f90 +++ b/src/phase.f90 @@ -398,9 +398,9 @@ subroutine phase_init phase => phases%get_dict(ph) refs = config_listReferences(phase,indent=3) if (len(refs) > 0) print'(/,1x,a)', refs - phase_lattice(ph) = phase%get_asString('lattice') + phase_lattice(ph) = phase%get_asStr('lattice') if (all(phase_lattice(ph) /= ['cF','cI','hP','tI'])) & - call IO_error(130,ext_msg='phase_init: '//phase%get_asString('lattice')) + call IO_error(130,ext_msg='phase_init: '//phase%get_asStr('lattice')) if (any(phase_lattice(ph) == ['hP','tI'])) & phase_cOverA(ph) = phase%get_asReal('c/a') phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pReal) diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index 34565d308..43e39a980 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -484,7 +484,7 @@ function source_active(source_label) result(active_source) do ph = 1, phases%length phase => phases%get_dict(ph) src => phase%get_dict('damage',defaultVal=emptyDict) - active_source(ph) = src%get_asString('type',defaultVal = 'x') == source_label + active_source(ph) = src%get_asStr('type',defaultVal = 'x') == source_label end do diff --git a/src/phase_damage_anisobrittle.f90 b/src/phase_damage_anisobrittle.f90 index 427c4aa11..4c1148b79 100644 --- a/src/phase_damage_anisobrittle.f90 +++ b/src/phase_damage_anisobrittle.f90 @@ -17,7 +17,7 @@ submodule (phase:damage) anisobrittle cleavage_systems integer :: & sum_N_cl !< total number of cleavage planes - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -84,9 +84,9 @@ module function anisobrittle_init() result(mySources) prm%g_crit = math_expand(prm%g_crit,N_cl) #if defined (__GFORTRAN__) - prm%output = output_as1dString(src) + prm%output = output_as1dStr(src) #else - prm%output = src%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = src%get_as1dStr('output',defaultVal=emptyStrArray) #endif ! sanity checks diff --git a/src/phase_damage_isobrittle.f90 b/src/phase_damage_isobrittle.f90 index 569cb3cbb..fcc8393b9 100644 --- a/src/phase_damage_isobrittle.f90 +++ b/src/phase_damage_isobrittle.f90 @@ -9,7 +9,7 @@ submodule(phase:damage) isobrittle type :: tParameters !< container type for internal constitutive parameters real(pReal) :: & W_crit !< critical elastic strain energy - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -71,9 +71,9 @@ module function isobrittle_init() result(mySources) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(src) + prm%output = output_as1dStr(src) #else - prm%output = src%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = src%get_as1dStr('output',defaultVal=emptyStrArray) #endif ! sanity checks diff --git a/src/phase_mechanical.f90 b/src/phase_mechanical.f90 index 4049914de..4df932650 100644 --- a/src/phase_mechanical.f90 +++ b/src/phase_mechanical.f90 @@ -184,7 +184,7 @@ submodule(phase) mechanical end interface type :: tOutput !< requested output (per phase) - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & label end type tOutput type(tOutput), allocatable, dimension(:) :: output_mechanical @@ -254,9 +254,9 @@ module subroutine mechanical_init(phases) phase => phases%get_dict(ph) mech => phase%get_dict('mechanical') #if defined(__GFORTRAN__) - output_mechanical(ph)%label = output_as1dString(mech) + output_mechanical(ph)%label = output_as1dStr(mech) #else - output_mechanical(ph)%label = mech%get_as1dString('output',defaultVal=emptyStringArray) + output_mechanical(ph)%label = mech%get_as1dStr('output',defaultVal=emptyStrArray) #endif end do @@ -291,7 +291,7 @@ module subroutine mechanical_init(phases) num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict) - select case(num_crystallite%get_asString('integrator',defaultVal='FPI')) + select case(num_crystallite%get_asStr('integrator',defaultVal='FPI')) case('FPI') integrateState => integrateStateFPI diff --git a/src/phase_mechanical_eigen.f90 b/src/phase_mechanical_eigen.f90 index 6b7a079b0..bf45a2468 100644 --- a/src/phase_mechanical_eigen.f90 +++ b/src/phase_mechanical_eigen.f90 @@ -101,7 +101,7 @@ function kinematics_active(kinematics_label,kinematics_length) result(active_ki kinematics => mechanics%get_list('eigen',defaultVal=emptyList) do k = 1, kinematics%length kinematic => kinematics%get_dict(k) - active_kinematics(k,ph) = kinematic%get_asString('type') == kinematics_label + active_kinematics(k,ph) = kinematic%get_asStr('type') == kinematics_label end do end do @@ -129,7 +129,7 @@ function kinematics_active2(kinematics_label) result(active_kinematics) do ph = 1, phases%length phase => phases%get_dict(ph) kinematics_type => phase%get_dict('damage',defaultVal=emptyDict) - active_kinematics(ph) = kinematics_type%get_asString('type',defaultVal='n/a') == kinematics_label + active_kinematics(ph) = kinematics_type%get_asStr('type',defaultVal='n/a') == kinematics_label end do diff --git a/src/phase_mechanical_elastic.f90 b/src/phase_mechanical_elastic.f90 index 15a5d29c2..9adcec823 100644 --- a/src/phase_mechanical_elastic.f90 +++ b/src/phase_mechanical_elastic.f90 @@ -46,7 +46,7 @@ module subroutine elastic_init(phases) print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph) refs = config_listReferences(elastic,indent=3) if (len(refs) > 0) print'(/,1x,a)', refs - if (elastic%get_asString('type') /= 'Hooke') call IO_error(200,ext_msg=elastic%get_asString('type')) + if (elastic%get_asStr('type') /= 'Hooke') call IO_error(200,ext_msg=elastic%get_asStr('type')) associate(prm => param(ph)) diff --git a/src/phase_mechanical_plastic.f90 b/src/phase_mechanical_plastic.f90 index 4140e0805..c4736ea29 100644 --- a/src/phase_mechanical_plastic.f90 +++ b/src/phase_mechanical_plastic.f90 @@ -434,7 +434,7 @@ function plastic_active(plastic_label) result(active_plastic) phase => phases%get_dict(ph) mech => phase%get_dict('mechanical') pl => mech%get_dict('plastic',defaultVal = emptyDict) - active_plastic(ph) = pl%get_asString('type',defaultVal='none') == plastic_label + active_plastic(ph) = pl%get_asStr('type',defaultVal='none') == plastic_label end do end function plastic_active diff --git a/src/phase_mechanical_plastic_dislotungsten.f90 b/src/phase_mechanical_plastic_dislotungsten.f90 index ff949a51e..45a2f029f 100644 --- a/src/phase_mechanical_plastic_dislotungsten.f90 +++ b/src/phase_mechanical_plastic_dislotungsten.f90 @@ -37,7 +37,7 @@ submodule(phase:plastic) dislotungsten sum_N_sl !< total number of active slip system character(len=:), allocatable :: & isotropic_bound - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output logical :: & dipoleFormation !< flag indicating consideration of dipole formation @@ -135,12 +135,12 @@ module function plastic_dislotungsten_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif - prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain') + prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain') !-------------------------------------------------------------------------------------------------- ! slip related parameters diff --git a/src/phase_mechanical_plastic_dislotwin.f90 b/src/phase_mechanical_plastic_dislotwin.f90 index 7bdeb09fb..ea8570ba0 100644 --- a/src/phase_mechanical_plastic_dislotwin.f90 +++ b/src/phase_mechanical_plastic_dislotwin.f90 @@ -75,7 +75,7 @@ submodule(phase:plastic) dislotwin character(len=:), allocatable :: & lattice_tr, & isotropic_bound - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output logical :: & extendedDislocations, & !< consider split into partials for climb calculation @@ -188,12 +188,12 @@ module function plastic_dislotwin_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif - prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain') + prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain') !-------------------------------------------------------------------------------------------------- ! slip related parameters diff --git a/src/phase_mechanical_plastic_isotropic.f90 b/src/phase_mechanical_plastic_isotropic.f90 index 39c95c6b8..c581776e7 100644 --- a/src/phase_mechanical_plastic_isotropic.f90 +++ b/src/phase_mechanical_plastic_isotropic.f90 @@ -25,7 +25,7 @@ submodule(phase:plastic) isotropic c_2 logical :: & dilatation - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters @@ -93,9 +93,9 @@ module function plastic_isotropic_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif xi_0 = pl%get_asReal('xi_0') diff --git a/src/phase_mechanical_plastic_kinehardening.f90 b/src/phase_mechanical_plastic_kinehardening.f90 index 5268d0bb9..d4bd41164 100644 --- a/src/phase_mechanical_plastic_kinehardening.f90 +++ b/src/phase_mechanical_plastic_kinehardening.f90 @@ -32,9 +32,9 @@ submodule(phase:plastic) kinehardening sum_N_sl logical :: & nonSchmidActive = .false. - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output - character(len=:), allocatable, dimension(:) :: & + character(len=:), allocatable, dimension(:) :: & systems_sl end type tParameters @@ -128,9 +128,9 @@ module function plastic_kinehardening_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif !-------------------------------------------------------------------------------------------------- diff --git a/src/phase_mechanical_plastic_nonlocal.f90 b/src/phase_mechanical_plastic_nonlocal.f90 index eca1aa7e5..f67e383e3 100644 --- a/src/phase_mechanical_plastic_nonlocal.f90 +++ b/src/phase_mechanical_plastic_nonlocal.f90 @@ -117,7 +117,7 @@ submodule(phase:plastic) nonlocal colinearSystem !< colinear system to the active slip system (only valid for fcc!) character(len=:), allocatable :: & isotropic_bound - character(len=pStringLen), dimension(:), allocatable :: & + character(len=pSTRLEN), dimension(:), allocatable :: & output logical :: & shortRangeStressCorrection, & !< use of short range stress correction by excess density gradient term @@ -241,13 +241,13 @@ module function plastic_nonlocal_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif plasticState(ph)%nonlocal = pl%get_asBool('flux',defaultVal=.True.) - prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain') + prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain') prm%atol_rho = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) ini%N_sl = pl%get_as1dInt('N_sl',defaultVal=emptyIntArray) diff --git a/src/phase_mechanical_plastic_phenopowerlaw.f90 b/src/phase_mechanical_plastic_phenopowerlaw.f90 index 59b75df87..a32c0ea67 100644 --- a/src/phase_mechanical_plastic_phenopowerlaw.f90 +++ b/src/phase_mechanical_plastic_phenopowerlaw.f90 @@ -40,7 +40,7 @@ submodule(phase:plastic) phenopowerlaw sum_N_tw !< total number of active twin systems logical :: & nonSchmidActive = .false. - character(len=pStringLen), allocatable, dimension(:) :: & + character(len=pSTRLEN), allocatable, dimension(:) :: & output character(len=:), allocatable, dimension(:) :: & systems_sl, & @@ -129,9 +129,9 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) if (len(refs) > 0) print'(/,1x,a)', refs #if defined (__GFORTRAN__) - prm%output = output_as1dString(pl) + prm%output = output_as1dStr(pl) #else - prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray) + prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray) #endif !-------------------------------------------------------------------------------------------------- diff --git a/src/phase_thermal.f90 b/src/phase_thermal.f90 index 878d2c9ae..325076c08 100644 --- a/src/phase_thermal.f90 +++ b/src/phase_thermal.f90 @@ -6,7 +6,7 @@ submodule(phase) thermal type :: tThermalParameters real(pReal) :: C_p = 0.0_pReal !< heat capacity real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity - character(len=pStringLen), allocatable, dimension(:) :: output + character(len=pSTRLEN), allocatable, dimension(:) :: output end type tThermalParameters integer, dimension(:), allocatable :: & @@ -115,9 +115,9 @@ module subroutine thermal_init(phases) param(ph)%K = lattice_symmetrize_33(param(ph)%K,phase_lattice(ph)) #if defined(__GFORTRAN__) - param(ph)%output = output_as1dString(thermal) + param(ph)%output = output_as1dStr(thermal) #else - param(ph)%output = thermal%get_as1dString('output',defaultVal=emptyStringArray) + param(ph)%output = thermal%get_as1dStr('output',defaultVal=emptyStrArray) #endif sources => thermal%get_list('source',defaultVal=emptyList) thermal_Nsources(ph) = sources%length @@ -387,7 +387,7 @@ function thermal_active(source_label,src_length) result(active_source) sources => thermal%get_list('source',defaultVal=emptyList) do s = 1, sources%length src => sources%get_dict(s) - active_source(s,p) = src%get_asString('type') == source_label + active_source(s,p) = src%get_asStr('type') == source_label end do end do diff --git a/src/polynomials.f90 b/src/polynomials.f90 index 1e1f2b842..103a9b695 100644 --- a/src/polynomials.f90 +++ b/src/polynomials.f90 @@ -127,8 +127,8 @@ subroutine selfTest() integer :: i real(pReal) :: x_ref, x, y type(tDict), pointer :: dict - character(len=pStringLen), dimension(size(coef)) :: coef_s - character(len=pStringLen) :: x_ref_s, x_s, YAML_s + character(len=pSTRLEN), dimension(size(coef)) :: coef_s + character(len=pSTRLEN) :: x_ref_s, x_s, YAML_s call random_number(coef) diff --git a/src/prec.f90 b/src/prec.f90 index ccf6dc9f9..6aa08567c 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -28,7 +28,7 @@ module prec PetscScalar, private :: dummy_scalar real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar) #endif - integer, parameter :: pSTRINGLEN = 256 !< default string length + integer, parameter :: pSTRLEN = 256 !< default string length integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux real(pReal), parameter :: tol_math_check = 1.0e-8_pReal !< tolerance for internal math self-checks (rotation) @@ -37,9 +37,9 @@ module prec real(pReal), private, parameter :: PREAL_EPSILON = epsilon(0.0_pReal) !< minimum positive number such that 1.0 + EPSILON /= 1.0. real(pReal), private, parameter :: PREAL_MIN = tiny(0.0_pReal) !< smallest normalized floating point number - integer, dimension(0), parameter :: emptyIntArray = [integer::] - real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] - character(len=pStringLen), dimension(0), parameter :: emptyStringArray = [character(len=pStringLen)::] + integer, dimension(0), parameter :: emptyIntArray = [integer::] + real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] + character(len=pSTRLEN), dimension(0), parameter :: emptyStrArray = [character(len=pSTRLEN)::] contains diff --git a/src/result.f90 b/src/result.f90 index 0f29e9e53..da538f734 100644 --- a/src/result.f90 +++ b/src/result.f90 @@ -143,7 +143,7 @@ subroutine result_addIncrement(inc,time) integer, intent(in) :: inc real(pReal), intent(in) :: time - character(len=pStringLen) :: incChar + character(len=pSTRLEN) :: incChar write(incChar,'(i10)') inc @@ -488,7 +488,7 @@ subroutine result_mapping_phase(ID,entry,label) plist_id, & dt_id - integer(SIZE_T) :: type_size_string, type_size_int + integer(SIZE_T) :: type_size_str, type_size_int integer :: hdferr, ce, co integer(MPI_INTEGER_KIND) :: err_MPI @@ -536,23 +536,23 @@ subroutine result_mapping_phase(ID,entry,label) call HDF5_chkerr(hdferr) call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) call HDF5_chkerr(hdferr) - call H5Tget_size_f(dt_id, type_size_string, hdferr) + call H5Tget_size_f(dt_id, type_size_str, hdferr) call HDF5_chkerr(hdferr) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) call H5Tget_size_f(pI64_t, type_size_int, hdferr) call HDF5_chkerr(hdferr) - call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) + call H5Tcreate_f(H5T_COMPOUND_F, type_size_str + type_size_int, dtype_id, hdferr) call HDF5_chkerr(hdferr) call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) call HDF5_chkerr(hdferr) - call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) + call H5Tinsert_f(dtype_id, 'entry', type_size_str, pI64_t, hdferr) call HDF5_chkerr(hdferr) !-------------------------------------------------------------------------------------------------- ! create memory types for each component of the compound type - call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) + call H5Tcreate_f(H5T_COMPOUND_F, type_size_str, label_id, hdferr) call HDF5_chkerr(hdferr) call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) call HDF5_chkerr(hdferr) @@ -644,7 +644,7 @@ subroutine result_mapping_homogenization(ID,entry,label) plist_id, & dt_id - integer(SIZE_T) :: type_size_string, type_size_int + integer(SIZE_T) :: type_size_str, type_size_int integer :: hdferr, ce integer(MPI_INTEGER_KIND) :: err_MPI @@ -688,23 +688,23 @@ subroutine result_mapping_homogenization(ID,entry,label) call HDF5_chkerr(hdferr) call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) call HDF5_chkerr(hdferr) - call H5Tget_size_f(dt_id, type_size_string, hdferr) + call H5Tget_size_f(dt_id, type_size_str, hdferr) call HDF5_chkerr(hdferr) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) call H5Tget_size_f(pI64_t, type_size_int, hdferr) call HDF5_chkerr(hdferr) - call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) + call H5Tcreate_f(H5T_COMPOUND_F, type_size_str + type_size_int, dtype_id, hdferr) call HDF5_chkerr(hdferr) call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) call HDF5_chkerr(hdferr) - call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) + call H5Tinsert_f(dtype_id, 'entry', type_size_str, pI64_t, hdferr) call HDF5_chkerr(hdferr) !-------------------------------------------------------------------------------------------------- ! create memory types for each component of the compound type - call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) + call H5Tcreate_f(H5T_COMPOUND_F, type_size_str, label_id, hdferr) call HDF5_chkerr(hdferr) call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) call HDF5_chkerr(hdferr) diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 0ac8eadd0..5207b5b94 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -47,8 +47,8 @@ module system_routines use prec implicit none(type,external) - character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: hostname ! NULL-terminated array - integer(C_INT), intent(out) :: stat + character(kind=C_CHAR), dimension(pSTRLEN+1), intent(out) :: hostname ! NULL-terminated array + integer(C_INT), intent(out) :: stat end subroutine getHostName_C subroutine getUserName_C(username, stat) bind(C) @@ -56,8 +56,8 @@ module system_routines use prec implicit none(type,external) - character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: username ! NULL-terminated array - integer(C_INT), intent(out) :: stat + character(kind=C_CHAR), dimension(pSTRLEN+1), intent(out) :: username ! NULL-terminated array + integer(C_INT), intent(out) :: stat end subroutine getUserName_C subroutine signalint_C(handler) bind(C) @@ -135,7 +135,7 @@ function getHostName() character(len=:), allocatable :: getHostName - character(kind=C_CHAR), dimension(pStringLen+1) :: getHostName_Cstring + character(kind=C_CHAR), dimension(pSTRLEN+1) :: getHostName_Cstring integer(C_INT) :: stat @@ -157,7 +157,7 @@ function getUserName() character(len=:), allocatable :: getUserName - character(kind=C_CHAR), dimension(pStringLen+1) :: getUserName_Cstring + character(kind=C_CHAR), dimension(pSTRLEN+1) :: getUserName_Cstring integer(C_INT) :: stat From 319489fad8e422fe3e1bc7e29e69479e52c4c754 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Jun 2023 07:21:41 +0200 Subject: [PATCH 4/7] consistent with usage in other modules --- src/misc.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/misc.f90 b/src/misc.f90 index b4936b070..c912bc744 100644 --- a/src/misc.f90 +++ b/src/misc.f90 @@ -11,7 +11,7 @@ module misc interface misc_optional module procedure misc_optional_bool - module procedure misc_optional_integer + module procedure misc_optional_int module procedure misc_optional_real module procedure misc_optional_str end interface misc_optional @@ -57,7 +57,7 @@ end function misc_optional_bool !-------------------------------------------------------------------------------------------------- !> @brief Return integer value if given, otherwise default. !-------------------------------------------------------------------------------------------------- -pure function misc_optional_integer(given,default) result(var) +pure function misc_optional_int(given,default) result(var) integer, intent(in), optional :: given integer, intent(in) :: default @@ -70,7 +70,7 @@ pure function misc_optional_integer(given,default) result(var) var = default end if -end function misc_optional_integer +end function misc_optional_int !-------------------------------------------------------------------------------------------------- @@ -136,7 +136,7 @@ contains function test_str(str_in) result(str_out) - character(len=:), allocatable :: str_out + character(len=:), allocatable :: str_out character(len=*), intent(in), optional :: str_in @@ -151,7 +151,7 @@ contains integer, intent(in), optional :: int_in - int_out = misc_optional_integer(int_in,42) + int_out = misc_optional_int(int_in,42) end function test_int From 0324e7ece1f00a678eb82b5e705a05532e328827 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 4 Jun 2023 07:22:25 +0200 Subject: [PATCH 5/7] parameters should be spelled in capitals --- src/HDF5_utilities.f90 | 38 +- src/IO.f90 | 20 +- src/LAPACK_interface.f90 | 26 +- src/Marc/DAMASK_Marc.f90 | 44 +- src/Marc/discretization_Marc.f90 | 62 +-- src/Marc/materialpoint_Marc.f90 | 48 +- src/YAML_types.f90 | 30 +- src/constants.f90 | 8 +- src/discretization.f90 | 10 +- src/geometry_plastic_nonlocal.f90 | 18 +- src/grid/DAMASK_grid.f90 | 42 +- src/grid/VTI.f90 | 24 +- src/grid/discretization_grid.f90 | 52 +- src/grid/grid_damage_spectral.f90 | 42 +- src/grid/grid_mech_FEM.f90 | 166 +++---- src/grid/grid_mech_spectral_basic.f90 | 90 ++-- src/grid/grid_mech_spectral_polarisation.f90 | 124 ++--- src/grid/grid_thermal_spectral.f90 | 40 +- src/grid/spectral_utilities.f90 | 354 ++++++------- src/homogenization.f90 | 40 +- src/homogenization_damage.f90 | 20 +- src/homogenization_mechanical.f90 | 36 +- src/homogenization_mechanical_RGC.f90 | 234 ++++----- src/homogenization_mechanical_isostrain.f90 | 4 +- src/homogenization_thermal.f90 | 14 +- src/lattice.f90 | 382 +++++++------- src/material.f90 | 14 +- src/materialpoint.f90 | 2 +- src/math.f90 | 448 ++++++++--------- src/mesh/DAMASK_mesh.f90 | 24 +- src/mesh/FEM_quadrature.f90 | 280 +++++------ src/mesh/FEM_utilities.f90 | 14 +- src/mesh/discretization_mesh.f90 | 18 +- src/mesh/mesh_mech_FEM.f90 | 102 ++-- src/misc.f90 | 20 +- src/parallelization.f90 | 4 +- src/phase.f90 | 128 ++--- src/phase_damage.f90 | 64 +-- src/phase_damage_anisobrittle.f90 | 42 +- src/phase_damage_isobrittle.f90 | 24 +- src/phase_mechanical.f90 | 252 +++++----- src/phase_mechanical_eigen.f90 | 24 +- ...hase_mechanical_eigen_thermalexpansion.f90 | 12 +- src/phase_mechanical_elastic.f90 | 28 +- src/phase_mechanical_plastic.f90 | 88 ++-- ...phase_mechanical_plastic_dislotungsten.f90 | 148 +++--- src/phase_mechanical_plastic_dislotwin.f90 | 352 ++++++------- src/phase_mechanical_plastic_isotropic.f90 | 92 ++-- ...phase_mechanical_plastic_kinehardening.f90 | 98 ++-- src/phase_mechanical_plastic_nonlocal.f90 | 466 +++++++++--------- ...phase_mechanical_plastic_phenopowerlaw.f90 | 142 +++--- src/phase_thermal.f90 | 30 +- src/phase_thermal_dissipation.f90 | 6 +- src/phase_thermal_externalheat.f90 | 4 +- src/polynomials.f90 | 40 +- src/prec.f90 | 58 +-- src/result.f90 | 14 +- src/rotations.f90 | 324 ++++++------ src/tables.f90 | 30 +- src/test/test_HDF5_utilities.f90 | 2 +- 60 files changed, 2681 insertions(+), 2681 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index c6af2facb..857fd30d1 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -135,8 +135,8 @@ subroutine HDF5_utilities_init() call H5Tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) call HDF5_chkerr(hdferr) - if (int(storage_size(0.0_pReal),SIZE_T)/=typeSize*8) & - error stop 'pReal does not match H5T_NATIVE_DOUBLE' + if (int(storage_size(0.0_pREAL),SIZE_T)/=typeSize*8) & + error stop 'pREAL does not match H5T_NATIVE_DOUBLE' call H5get_libversion_f(HDF5_major,HDF5_minor,HDF5_release,hdferr) call HDF5_chkerr(hdferr) @@ -443,7 +443,7 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue + real(pREAL), intent(in) :: attrValue character(len=*), intent(in), optional :: path integer(HID_T) :: attr_id, space_id @@ -576,7 +576,7 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel - real(pReal), intent(in), dimension(:) :: attrValue + real(pREAL), intent(in), dimension(:) :: attrValue character(len=*), intent(in), optional :: path integer(HSIZE_T),dimension(1) :: array_size @@ -640,7 +640,7 @@ end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -674,7 +674,7 @@ end subroutine HDF5_read_real1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:,:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -708,7 +708,7 @@ end subroutine HDF5_read_real2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:,:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:,:,:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -742,7 +742,7 @@ end subroutine HDF5_read_real3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:,:,:) :: dataset !< read data + real(pREAL), intent(out), dimension(:,:,:,:) :: dataset !< read data integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -777,7 +777,7 @@ end subroutine HDF5_read_real4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:,:,:,:,:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -812,7 +812,7 @@ end subroutine HDF5_read_real5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:,:,:,:,:,:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -847,7 +847,7 @@ end subroutine HDF5_read_real6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel) - real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset !< data read from file + real(pREAL), intent(out), dimension(:,:,:,:,:,:,:) :: dataset !< data read from file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1126,7 +1126,7 @@ end subroutine HDF5_read_int7 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1163,7 +1163,7 @@ end subroutine HDF5_write_real1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1200,7 +1200,7 @@ end subroutine HDF5_write_real2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1237,7 +1237,7 @@ end subroutine HDF5_write_real3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:,:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:,:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1275,7 +1275,7 @@ end subroutine HDF5_write_real4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:,:,:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:,:,:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1312,7 +1312,7 @@ end subroutine HDF5_write_real5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:,:,:,:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:,:,:,:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1349,7 +1349,7 @@ end subroutine HDF5_write_real6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(:,:,:,:,:,:,:) :: dataset !< data written to file + real(pREAL), intent(in), dimension(:,:,:,:,:,:,:) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes @@ -1388,7 +1388,7 @@ end subroutine HDF5_write_real7 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel) - real(pReal), intent(in), dimension(..) :: dataset !< data written to file + real(pREAL), intent(in), dimension(..) :: dataset !< data written to file integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes diff --git a/src/IO.f90 b/src/IO.f90 index 31ce19c29..27e650825 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -274,7 +274,7 @@ end function IO_intValue !-------------------------------------------------------------------------------------------------- !> @brief Read real value at myChunk from string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_realValue(str,chunkPos,myChunk) +real(pREAL) function IO_realValue(str,chunkPos,myChunk) character(len=*), intent(in) :: str !< raw input with known start and end of each chunk integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string @@ -373,7 +373,7 @@ end function IO_strAsInt !-------------------------------------------------------------------------------------------------- !> @brief Return real value from given string. !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_strAsReal(str) +real(pREAL) function IO_strAsReal(str) character(len=*), intent(in) :: str !< string for conversion to real value @@ -385,7 +385,7 @@ real(pReal) function IO_strAsReal(str) read(str,*,iostat=readStatus) IO_strAsReal if (readStatus /= 0) call IO_error(112,str) else valid - IO_strAsReal = 0.0_pReal + IO_strAsReal = 0.0_pREAL call IO_error(112,str) end if valid @@ -733,12 +733,12 @@ subroutine selfTest() character(len=:), allocatable :: str,out - if (dNeq(1.0_pReal, IO_strAsReal('1.0'))) error stop 'IO_strAsReal' - if (dNeq(1.0_pReal, IO_strAsReal('1e0'))) error stop 'IO_strAsReal' - if (dNeq(0.1_pReal, IO_strAsReal('1e-1'))) error stop 'IO_strAsReal' - if (dNeq(0.1_pReal, IO_strAsReal('1.0e-1'))) error stop 'IO_strAsReal' - if (dNeq(0.1_pReal, IO_strAsReal('1.00e-1'))) error stop 'IO_strAsReal' - if (dNeq(10._pReal, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal' + if (dNeq(1.0_pREAL, IO_strAsReal('1.0'))) error stop 'IO_strAsReal' + if (dNeq(1.0_pREAL, IO_strAsReal('1e0'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pREAL, IO_strAsReal('1e-1'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pREAL, IO_strAsReal('1.0e-1'))) error stop 'IO_strAsReal' + if (dNeq(0.1_pREAL, IO_strAsReal('1.00e-1'))) error stop 'IO_strAsReal' + if (dNeq(10._pREAL, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal' if (3112019 /= IO_strAsInt( '3112019')) error stop 'IO_strAsInt' if (3112019 /= IO_strAsInt(' 3112019')) error stop 'IO_strAsInt' @@ -760,7 +760,7 @@ subroutine selfTest() str = ' 1.0 xxx' chunkPos = IO_strPos(str) - if (dNeq(1.0_pReal,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue' + if (dNeq(1.0_pREAL,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue' str = 'M 3112019 F' chunkPos = IO_strPos(str) diff --git a/src/LAPACK_interface.f90 b/src/LAPACK_interface.f90 index cc451b59c..deb9d92e6 100644 --- a/src/LAPACK_interface.f90 +++ b/src/LAPACK_interface.f90 @@ -12,11 +12,11 @@ module LAPACK_interface character, intent(in) :: jobvl,jobvr integer, intent(in) :: n,lda,ldvl,ldvr,lwork - real(pReal), intent(inout), dimension(lda,n) :: a - real(pReal), intent(out), dimension(n) :: wr,wi - real(pReal), intent(out), dimension(ldvl,n) :: vl - real(pReal), intent(out), dimension(ldvr,n) :: vr - real(pReal), intent(out), dimension(max(1,lwork)) :: work + real(pREAL), intent(inout), dimension(lda,n) :: a + real(pREAL), intent(out), dimension(n) :: wr,wi + real(pREAL), intent(out), dimension(ldvl,n) :: vl + real(pREAL), intent(out), dimension(ldvr,n) :: vr + real(pREAL), intent(out), dimension(max(1,lwork)) :: work integer, intent(out) :: info end subroutine dgeev @@ -25,9 +25,9 @@ module LAPACK_interface implicit none(type,external) integer, intent(in) :: n,nrhs,lda,ldb - real(pReal), intent(inout), dimension(lda,n) :: a + real(pREAL), intent(inout), dimension(lda,n) :: a integer, intent(out), dimension(n) :: ipiv - real(pReal), intent(inout), dimension(ldb,nrhs) :: b + real(pREAL), intent(inout), dimension(ldb,nrhs) :: b integer, intent(out) :: info end subroutine dgesv @@ -36,7 +36,7 @@ module LAPACK_interface implicit none(type,external) integer, intent(in) :: m,n,lda - real(pReal), intent(inout), dimension(lda,n) :: a + real(pREAL), intent(inout), dimension(lda,n) :: a integer, intent(out), dimension(min(m,n)) :: ipiv integer, intent(out) :: info end subroutine dgetrf @@ -46,9 +46,9 @@ module LAPACK_interface implicit none(type,external) integer, intent(in) :: n,lda,lwork - real(pReal), intent(inout), dimension(lda,n) :: a + real(pREAL), intent(inout), dimension(lda,n) :: a integer, intent(in), dimension(n) :: ipiv - real(pReal), intent(out), dimension(max(1,lwork)) :: work + real(pREAL), intent(out), dimension(max(1,lwork)) :: work integer, intent(out) :: info end subroutine dgetri @@ -58,9 +58,9 @@ module LAPACK_interface character, intent(in) :: jobz,uplo integer, intent(in) :: n,lda,lwork - real(pReal), intent(inout), dimension(lda,n) :: a - real(pReal), intent(out), dimension(n) :: w - real(pReal), intent(out), dimension(max(1,lwork)) :: work + real(pREAL), intent(inout), dimension(lda,n) :: a + real(pREAL), intent(out), dimension(n) :: w + real(pREAL), intent(out), dimension(max(1,lwork)) :: work integer, intent(out) :: info end subroutine dsyev diff --git a/src/Marc/DAMASK_Marc.f90 b/src/Marc/DAMASK_Marc.f90 index 1b978c0cb..032c77394 100644 --- a/src/Marc/DAMASK_Marc.f90 +++ b/src/Marc/DAMASK_Marc.f90 @@ -233,32 +233,32 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & matus, & !< (1) user material identification number, (2) internal material identification number kcus, & !< (1) layer number, (2) internal layer number lclass !< (1) element class, (2) 0: displacement, 1: low order Herrmann, 2: high order Herrmann - real(pReal), dimension(*), intent(in) :: & ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*) + real(pREAL), dimension(*), intent(in) :: & ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*) e, & !< total elastic strain de, & !< increment of strain dt !< increment of state variables - real(pReal), dimension(itel), intent(in) :: & ! according to MSC.Marc 2012 Manual D + real(pREAL), dimension(itel), intent(in) :: & ! according to MSC.Marc 2012 Manual D strechn, & !< square of principal stretch ratios, lambda(i) at t=n strechn1 !< square of principal stretch ratios, lambda(i) at t=n+1 - real(pReal), dimension(3,3), intent(in) :: & ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3) + real(pREAL), dimension(3,3), intent(in) :: & ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3) ffn, & !< deformation gradient at t=n ffn1 !< deformation gradient at t=n+1 - real(pReal), dimension(itel,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + real(pREAL), dimension(itel,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D frotn, & !< rotation tensor at t=n eigvn, & !< i principal direction components for j eigenvalues at t=n frotn1, & !< rotation tensor at t=n+1 eigvn1 !< i principal direction components for j eigenvalues at t=n+1 - real(pReal), dimension(ndeg,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + real(pREAL), dimension(ndeg,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D disp, & !< incremental displacements dispt !< displacements at t=n (at assembly, lovl=4) and displacements at t=n+1 (at stress recovery, lovl=6) - real(pReal), dimension(ncrd,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + real(pREAL), dimension(ncrd,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D coord !< coordinates - real(pReal), dimension(*), intent(inout) :: & ! according to MSC.Marc 2012 Manual D + real(pREAL), dimension(*), intent(inout) :: & ! according to MSC.Marc 2012 Manual D t !< state variables (comes in at t=n, must be updated to have state variables at t=n+1) - real(pReal), dimension(ndi+nshear), intent(out) :: & ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it + real(pREAL), dimension(ndi+nshear), intent(out) :: & ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it s, & !< stress - should be updated by user g !< change in stress due to temperature effects - real(pReal), dimension(ngens,ngens), intent(out) :: & ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*) + real(pREAL), dimension(ngens,ngens), intent(out) :: & ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*) d !< stress-strain law to be formed !-------------------------------------------------------------------------------------------------- @@ -269,17 +269,17 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & #include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment) logical :: cutBack - real(pReal), dimension(6) :: stress - real(pReal), dimension(6,6) :: ddsdde + real(pREAL), dimension(6) :: stress + real(pREAL), dimension(6,6) :: ddsdde integer :: computationMode, i, node, CPnodeID integer(pI32) :: defaultNumThreadsInt !< default value set by Marc integer, save :: & theInc = -1, & !< needs description lastLovl = 0 !< lovl in previous call to marc hypela2 - real(pReal), save :: & - theTime = 0.0_pReal, & !< needs description - theDelta = 0.0_pReal + real(pREAL), save :: & + theTime = 0.0_pREAL, & !< needs description + theDelta = 0.0_pREAL logical, save :: & lastIncConverged = .false., & !< needs description outdatedByNewInc = .false., & !< needs description @@ -351,8 +351,8 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & d = ddsdde(1:ngens,1:ngens) s = stress(1:ndi+nshear) - g = 0.0_pReal - if (symmetricSolver) d = 0.5_pReal*(d+transpose(d)) + g = 0.0_pREAL + if (symmetricSolver) d = 0.5_pREAL*(d+transpose(d)) call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value @@ -368,18 +368,18 @@ subroutine flux(f,ts,n,time) use discretization_Marc implicit none(type,external) - real(pReal), dimension(6), intent(in) :: & + real(pREAL), dimension(6), intent(in) :: & ts integer(pI64), dimension(10), intent(in) :: & n - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & time - real(pReal), dimension(2), intent(out) :: & + real(pREAL), dimension(2), intent(out) :: & f f(1) = homogenization_f_T(discretization_Marc_FEM2DAMASK_cell(int(n(3)),int(n(1)))) - f(2) = 0.0_pReal + f(2) = 0.0_pREAL end subroutine flux @@ -402,7 +402,7 @@ subroutine uedinc(inc,incsub) integer :: n, nqncomp, nqdatatype integer, save :: inc_written - real(pReal), allocatable, dimension(:,:) :: d_n + real(pREAL), allocatable, dimension(:,:) :: d_n #include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment) @@ -411,7 +411,7 @@ subroutine uedinc(inc,incsub) do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1) if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype) - if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal + if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pREAL end if end do diff --git a/src/Marc/discretization_Marc.f90 b/src/Marc/discretization_Marc.f90 index 51459f1f2..63fe3f194 100644 --- a/src/Marc/discretization_Marc.f90 +++ b/src/Marc/discretization_Marc.f90 @@ -20,7 +20,7 @@ module discretization_Marc implicit none(type,external) private - real(pReal), public, protected :: & + real(pREAL), public, protected :: & mesh_unitlength !< physical length of one unit in mesh MD: needs systematic_name integer, dimension(:), allocatable, public, protected :: & @@ -51,7 +51,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine discretization_Marc_init - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & node0_elem, & !< node x,y,z coordinates (initially!) node0_cell type(tElement) :: elem @@ -61,11 +61,11 @@ subroutine discretization_Marc_init integer:: & Nelems !< total number of elements in the mesh - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & IP_reshaped integer, dimension(:,:), allocatable :: & connectivity_elem - real(pReal), dimension(:,:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:,:), allocatable :: & unscaledNormals type(tDict), pointer :: & @@ -75,8 +75,8 @@ subroutine discretization_Marc_init print'(/,a)', ' <<<+- discretization_Marc init -+>>>'; flush(6) num_commercialFEM => config_numerics%get_dict('commercialFEM',defaultVal = emptyDict) - mesh_unitlength = num_commercialFEM%get_asReal('unitlength',defaultVal=1.0_pReal) ! set physical extent of a length unit in mesh - if (mesh_unitlength <= 0.0_pReal) call IO_error(301,'unitlength') + mesh_unitlength = num_commercialFEM%get_asReal('unitlength',defaultVal=1.0_pREAL) ! set physical extent of a length unit in mesh + if (mesh_unitlength <= 0.0_pREAL) call IO_error(301,'unitlength') call inputRead(elem,node0_elem,connectivity_elem,materialAt) nElems = size(connectivity_elem,2) @@ -113,9 +113,9 @@ end subroutine discretization_Marc_init !-------------------------------------------------------------------------------------------------- subroutine discretization_Marc_updateNodeAndIpCoords(d_n) - real(pReal), dimension(:,:), intent(in) :: d_n + real(pREAL), dimension(:,:), intent(in) :: d_n - real(pReal), dimension(:,:), allocatable :: node_cell + real(pREAL), dimension(:,:), allocatable :: node_cell node_cell = buildCellNodes(discretization_NodeCoords0(1:3,1:maxval(discretization_Marc_FEM2DAMASK_node)) + d_n) @@ -134,7 +134,7 @@ function discretization_Marc_FEM2DAMASK_cell(IP_FEM,elem_FEM) result(cell) integer, intent(in) :: IP_FEM, elem_FEM integer :: cell - real(pReal), dimension(:,:), allocatable :: node_cell + real(pREAL), dimension(:,:), allocatable :: node_cell cell = (discretization_Marc_FEM2DAMASK_elem(elem_FEM)-1)*discretization_nIPs + IP_FEM @@ -155,7 +155,7 @@ subroutine writeGeometry(elem, & integer, dimension(:,:), intent(in) :: & connectivity_elem, & connectivity_cell_reshaped - real(pReal), dimension(:,:), intent(in) :: & + real(pREAL), dimension(:,:), intent(in) :: & coordinates_nodes, & coordinates_points @@ -187,7 +187,7 @@ end subroutine writeGeometry subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt) type(tElement), intent(out) :: elem - real(pReal), dimension(:,:), allocatable, intent(out) :: & + real(pREAL), dimension(:,:), allocatable, intent(out) :: & node0_elem !< node x,y,z coordinates (initially!) integer, dimension(:,:), allocatable, intent(out) :: & connectivity_elem @@ -535,7 +535,7 @@ end subroutine inputRead_mapNodes subroutine inputRead_elemNodes(nodes, & nNode,fileContent) - real(pReal), allocatable, dimension(:,:), intent(out) :: nodes + real(pREAL), allocatable, dimension(:,:), intent(out) :: nodes integer, intent(in) :: nNode character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines @@ -914,8 +914,8 @@ end subroutine buildCells !-------------------------------------------------------------------------------------------------- pure function buildCellNodes(node_elem) - real(pReal), dimension(:,:), intent(in) :: node_elem !< element nodes - real(pReal), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates + real(pREAL), dimension(:,:), intent(in) :: node_elem !< element nodes + real(pREAL), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates integer :: i, j, k, n @@ -927,13 +927,13 @@ pure function buildCellNodes(node_elem) do i = 1, size(cellNodeDefinition) do j = 1, size(cellNodeDefinition(i)%parents,1) n = n+1 - buildCellNodes(:,n) = 0.0_pReal + buildCellNodes(:,n) = 0.0_pREAL do k = 1, size(cellNodeDefinition(i)%parents,2) buildCellNodes(:,n) = buildCellNodes(:,n) & + buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) & - * real(cellNodeDefinition(i)%weights(j,k),pReal) + * real(cellNodeDefinition(i)%weights(j,k),pREAL) end do - buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal) + buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pREAL) end do end do @@ -945,8 +945,8 @@ end function buildCellNodes !-------------------------------------------------------------------------------------------------- pure function buildIPcoordinates(node_cell) - real(pReal), dimension(:,:), intent(in) :: node_cell !< cell node coordinates - real(pReal), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates + real(pREAL), dimension(:,:), intent(in) :: node_cell !< cell node coordinates + real(pREAL), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates integer, dimension(:,:), allocatable :: connectivity_cell_reshaped integer :: i, n, NcellNodesPerCell,Ncells @@ -959,12 +959,12 @@ pure function buildIPcoordinates(node_cell) allocate(buildIPcoordinates(3,Ncells)) do i = 1, size(connectivity_cell_reshaped,2) - buildIPcoordinates(:,i) = 0.0_pReal + buildIPcoordinates(:,i) = 0.0_pREAL do n = 1, size(connectivity_cell_reshaped,1) buildIPcoordinates(:,i) = buildIPcoordinates(:,i) & + node_cell(:,connectivity_cell_reshaped(n,i)) end do - buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal) + buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pREAL) end do end function buildIPcoordinates @@ -978,10 +978,10 @@ end function buildIPcoordinates pure function IPvolume(elem,node) type(tElement), intent(in) :: elem - real(pReal), dimension(:,:), intent(in) :: node + real(pREAL), dimension(:,:), intent(in) :: node - real(pReal), dimension(elem%nIPs,size(connectivity_cell,3)) :: IPvolume - real(pReal), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7 + real(pREAL), dimension(elem%nIPs,size(connectivity_cell,3)) :: IPvolume + real(pREAL), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7 integer :: e,i @@ -1022,7 +1022,7 @@ pure function IPvolume(elem,node) IPvolume(i,e) = dot_product((x7-x1)+(x6-x0),math_cross((x7-x2), (x3-x0))) & + dot_product((x6-x0), math_cross((x7-x2)+(x5-x0),(x7-x4))) & + dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0))) - IPvolume(i,e) = IPvolume(i,e)/12.0_pReal + IPvolume(i,e) = IPvolume(i,e)/12.0_pREAL end select end do end do @@ -1037,11 +1037,11 @@ pure function IPareaNormal(elem,nElem,node) type(tElement), intent(in) :: elem integer, intent(in) :: nElem - real(pReal), dimension(:,:), intent(in) :: node + real(pREAL), dimension(:,:), intent(in) :: node - real(pReal), dimension(3,elem%nIPneighbors,elem%nIPs,nElem) :: ipAreaNormal + real(pREAL), dimension(3,elem%nIPneighbors,elem%nIPs,nElem) :: ipAreaNormal - real(pReal), dimension (3,size(elem%cellFace,1)) :: nodePos + real(pREAL), dimension (3,size(elem%cellFace,1)) :: nodePos integer :: e,i,f,n,m m = size(elem%cellFace,1) @@ -1055,7 +1055,7 @@ pure function IPareaNormal(elem,nElem,node) case (1,2) ! 2D 3 or 4 node IPareaNormal(1,f,i,e) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector IPareaNormal(2,f,i,e) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector - IPareaNormal(3,f,i,e) = 0.0_pReal + IPareaNormal(3,f,i,e) = 0.0_pREAL case (3) ! 3D 4node IPareaNormal(1:3,f,i,e) = math_cross(nodePos(1:3,2) - nodePos(1:3,1), & nodePos(1:3,3) - nodePos(1:3,1)) @@ -1063,11 +1063,11 @@ pure function IPareaNormal(elem,nElem,node) ! Get the normal of the quadrilateral face as the average of four normals of triangular ! subfaces. Since the face consists only of two triangles, the sum has to be divided ! by two. This procedure tries to compensate for probable non-planar cell surfaces - IPareaNormal(1:3,f,i,e) = 0.0_pReal + IPareaNormal(1:3,f,i,e) = 0.0_pREAL do n = 1, m IPareaNormal(1:3,f,i,e) = IPareaNormal(1:3,f,i,e) & + math_cross(nodePos(1:3,mod(n+0,m)+1) - nodePos(1:3,n), & - nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pReal + nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pREAL end do end select end do diff --git a/src/Marc/materialpoint_Marc.f90 b/src/Marc/materialpoint_Marc.f90 index 01d28ec80..151b9c1d2 100644 --- a/src/Marc/materialpoint_Marc.f90 +++ b/src/Marc/materialpoint_Marc.f90 @@ -27,11 +27,11 @@ module materialpoint_Marc implicit none(type,external) private - real(pReal), dimension (:,:,:), allocatable, private :: & + real(pREAL), dimension (:,:,:), allocatable, private :: & materialpoint_cs !< Cauchy stress - real(pReal), dimension (:,:,:,:), allocatable, private :: & + real(pREAL), dimension (:,:,:,:), allocatable, private :: & materialpoint_dcsdE !< Cauchy stress tangent - real(pReal), dimension (:,:,:,:), allocatable, private :: & + real(pREAL), dimension (:,:,:,:), allocatable, private :: & materialpoint_dcsdE_knownGood !< known good tangent integer, public :: & @@ -95,9 +95,9 @@ subroutine materialpoint_init() print'(/,1x,a)', '<<<+- materialpoint init -+>>>'; flush(IO_STDOUT) - allocate(materialpoint_cs( 6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) - allocate(materialpoint_dcsdE( 6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) - allocate(materialpoint_dcsdE_knownGood(6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) + allocate(materialpoint_cs( 6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL) + allocate(materialpoint_dcsdE( 6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL) + allocate(materialpoint_dcsdE_knownGood(6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL) end subroutine materialpoint_init @@ -110,25 +110,25 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, integer, intent(in) :: elFE, & !< FE element number ip !< integration point number - real(pReal), intent(in) :: dt !< time increment - real(pReal), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0 + real(pREAL), intent(in) :: dt !< time increment + real(pREAL), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0 ffn1 !< deformation gradient for t=t1 integer, intent(in) :: mode !< computation mode 1: regular computation plus aging of results - real(pReal), intent(in) :: temperature_inp !< temperature - real(pReal), dimension(6), intent(out) :: cauchyStress !< stress as 6 vector - real(pReal), dimension(6,6), intent(out) :: jacobian !< jacobian as 66 tensor (Consistent tangent dcs/dE) + real(pREAL), intent(in) :: temperature_inp !< temperature + real(pREAL), dimension(6), intent(out) :: cauchyStress !< stress as 6 vector + real(pREAL), dimension(6,6), intent(out) :: jacobian !< jacobian as 66 tensor (Consistent tangent dcs/dE) - real(pReal) J_inverse, & ! inverse of Jacobian + real(pREAL) J_inverse, & ! inverse of Jacobian rnd - real(pReal), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress - real(pReal), dimension (3,3,3,3) :: H_sym, & + real(pREAL), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress + real(pREAL), dimension (3,3,3,3) :: H_sym, & H integer elCP, & ! crystal plasticity element number i, j, k, l, m, n, ph, homog, mySource,ce - real(pReal), parameter :: ODD_STRESS = 1e15_pReal, & !< return value for stress if terminallyIll - ODD_JACOBIAN = 1e50_pReal !< return value for jacobian if terminallyIll + real(pREAL), parameter :: ODD_STRESS = 1e15_pREAL, & !< return value for stress if terminallyIll + ODD_JACOBIAN = 1e50_pREAL !< return value for jacobian if terminallyIll elCP = discretization_Marc_FEM2DAMASK_elem(elFE) @@ -149,7 +149,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, validCalculation: if (terminallyIll) then call random_number(rnd) - if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal + if (rnd < 0.5_pREAL) rnd = rnd - 1.0_pREAL materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6) @@ -161,7 +161,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, terminalIllness: if (terminallyIll) then call random_number(rnd) - if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal + if (rnd < 0.5_pREAL) rnd = rnd - 1.0_pREAL materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6) @@ -169,22 +169,22 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, ! translate from P to sigma Kirchhoff = matmul(homogenization_P(1:3,1:3,ce), transpose(homogenization_F(1:3,1:3,ce))) - J_inverse = 1.0_pReal / math_det33(homogenization_F(1:3,1:3,ce)) + J_inverse = 1.0_pREAL / math_det33(homogenization_F(1:3,1:3,ce)) materialpoint_cs(1:6,ip,elCP) = math_sym33to6(J_inverse * Kirchhoff,weighted=.false.) ! translate from dP/dF to dCS/dE - H = 0.0_pReal + H = 0.0_pREAL do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3 H(i,j,k,l) = H(i,j,k,l) & + homogenization_F(j,m,ce) * homogenization_F(l,n,ce) & * homogenization_dPdF(i,m,k,n,ce) & - math_delta(j,l) * homogenization_F(i,m,ce) * homogenization_P(k,m,ce) & - + 0.5_pReal * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) & + + 0.5_pREAL * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) & + Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k)) end do; end do; end do; end do; end do; end do forall(i=1:3, j=1:3,k=1:3,l=1:3) & - H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) + H_sym(i,j,k,l) = 0.25_pREAL * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.) @@ -193,7 +193,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, end if - if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) & + if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pREAL)) & call IO_warning(601,label1='element (CP)',ID1=elCP,label2='IP',ID2=ip) cauchyStress = materialpoint_cs (1:6, ip,elCP) @@ -219,7 +219,7 @@ end subroutine materialpoint_forward subroutine materialpoint_result(inc,time) integer, intent(in) :: inc - real(pReal), intent(in) :: time + real(pREAL), intent(in) :: time call result_openJobFile() call result_addIncrement(inc,time) diff --git a/src/YAML_types.f90 b/src/YAML_types.f90 index a2cd6a472..6a56d1dbc 100644 --- a/src/YAML_types.f90 +++ b/src/YAML_types.f90 @@ -183,7 +183,7 @@ subroutine selfTest() s = '1' if (s%asInt() /= 1) error stop 'tScalar_asInt' if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)' - if (dNeq(s%asReal(),1.0_pReal)) error stop 'tScalar_asReal' + if (dNeq(s%asReal(),1.0_pREAL)) error stop 'tScalar_asReal' s = 'true' if (.not. s%asBool()) error stop 'tScalar_asBool' if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)' @@ -209,11 +209,11 @@ subroutine selfTest() call l%append(s1) call l%append(s2) if (l%length /= 2) error stop 'tList%len' - if (dNeq(l%get_asReal(1),1.0_pReal)) error stop 'tList_get_asReal' + if (dNeq(l%get_asReal(1),1.0_pREAL)) error stop 'tList_get_asReal' if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt' if (l%get_asStr(2) /= '2') error stop 'tList_get_asStr' if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt' - if (any(dNeq(l%as1dReal(),real([1.0,2.0],pReal)))) error stop 'tList_as1dReal' + if (any(dNeq(l%as1dReal(),real([1.0,2.0],pREAL)))) error stop 'tList_as1dReal' s1 = 'true' s2 = 'false' if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool' @@ -253,7 +253,7 @@ subroutine selfTest() if (d%asFormattedStr() /= '{one-two: [1, 2], three: 3, four: 4}') & error stop 'tDict_asFormattedStr' if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt' - if (dNeq(d%get_asReal('three'),3.0_pReal)) error stop 'tDict_get_asReal' + if (dNeq(d%get_asReal('three'),3.0_pREAL)) error stop 'tDict_get_asReal' if (d%get_asStr('three') /= '3') error stop 'tDict_get_asStr' if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt' call d%set('one-two',s4) @@ -376,7 +376,7 @@ end function tNode_asDict function tScalar_asReal(self) class(tScalar), intent(in), target :: self - real(pReal) :: tScalar_asReal + real(pREAL) :: tScalar_asReal tScalar_asReal = IO_strAsReal(self%value) @@ -481,7 +481,7 @@ end subroutine tList_append function tList_as1dReal(self) class(tList), intent(in), target :: self - real(pReal), dimension(:), allocatable :: tList_as1dReal + real(pREAL), dimension(:), allocatable :: tList_as1dReal integer :: i type(tItem), pointer :: item @@ -505,7 +505,7 @@ end function tList_as1dReal function tList_as2dReal(self) class(tList), intent(in), target :: self - real(pReal), dimension(:,:), allocatable :: tList_as2dReal + real(pREAL), dimension(:,:), allocatable :: tList_as2dReal integer :: i type(tList), pointer :: row_data @@ -724,7 +724,7 @@ function tList_get_asReal(self,i) result(nodeAsReal) class(tList), intent(in) :: self integer, intent(in) :: i - real(pReal) :: nodeAsReal + real(pREAL) :: nodeAsReal class(tScalar), pointer :: scalar @@ -742,7 +742,7 @@ function tList_get_as1dReal(self,i) result(nodeAs1dReal) class(tList), intent(in) :: self integer, intent(in) :: i - real(pReal), dimension(:), allocatable :: nodeAs1dReal + real(pREAL), dimension(:), allocatable :: nodeAs1dReal class(tList), pointer :: list @@ -1124,8 +1124,8 @@ function tDict_get_asReal(self,k,defaultVal) result(nodeAsReal) class(tDict), intent(in) :: self character(len=*), intent(in) :: k - real(pReal), intent(in), optional :: defaultVal - real(pReal) :: nodeAsReal + real(pREAL), intent(in), optional :: defaultVal + real(pREAL) :: nodeAsReal type(tScalar), pointer :: scalar @@ -1149,9 +1149,9 @@ function tDict_get_as1dReal(self,k,defaultVal,requiredSize) result(nodeAs1dReal) class(tDict), intent(in) :: self character(len=*), intent(in) :: k - real(pReal), intent(in), dimension(:), optional :: defaultVal + real(pREAL), intent(in), dimension(:), optional :: defaultVal integer, intent(in), optional :: requiredSize - real(pReal), dimension(:), allocatable :: nodeAs1dReal + real(pREAL), dimension(:), allocatable :: nodeAs1dReal type(tList), pointer :: list @@ -1179,9 +1179,9 @@ function tDict_get_as2dReal(self,k,defaultVal,requiredShape) result(nodeAs2dReal class(tDict), intent(in) :: self character(len=*), intent(in) :: k - real(pReal), intent(in), dimension(:,:), optional :: defaultVal + real(pREAL), intent(in), dimension(:,:), optional :: defaultVal integer, intent(in), dimension(2), optional :: requiredShape - real(pReal), dimension(:,:), allocatable :: nodeAs2dReal + real(pREAL), dimension(:,:), allocatable :: nodeAs2dReal type(tList), pointer :: list diff --git a/src/constants.f90 b/src/constants.f90 index 1cdbcc128..29d5ac69a 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -8,9 +8,9 @@ module constants implicit none(type,external) public - real(pReal), parameter :: & - T_ROOM = 293.15_pReal, & !< Room temperature (20°C) in K (https://en.wikipedia.org/wiki/ISO_1) - K_B = 1.380649e-23_pReal, & !< Boltzmann constant in J/Kelvin (https://doi.org/10.1351/goldbook) - N_A = 6.02214076e23_pReal !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook) + real(pREAL), parameter :: & + T_ROOM = 293.15_pREAL, & !< Room temperature (20°C) in K (https://en.wikipedia.org/wiki/ISO_1) + K_B = 1.380649e-23_pREAL, & !< Boltzmann constant in J/Kelvin (https://doi.org/10.1351/goldbook) + N_A = 6.02214076e23_pREAL !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook) end module constants diff --git a/src/discretization.f90 b/src/discretization.f90 index ad08c5bff..6afc41811 100644 --- a/src/discretization.f90 +++ b/src/discretization.f90 @@ -18,7 +18,7 @@ module discretization integer, public, protected, dimension(:), allocatable :: & discretization_materialAt !ToDo: discretization_ID_material - real(pReal), public, protected, dimension(:,:), allocatable :: & + real(pREAL), public, protected, dimension(:,:), allocatable :: & discretization_IPcoords0, & discretization_IPcoords, & discretization_NodeCoords0, & @@ -44,7 +44,7 @@ subroutine discretization_init(materialAt,& integer, dimension(:), intent(in) :: & materialAt - real(pReal), dimension(:,:), intent(in) :: & + real(pREAL), dimension(:,:), intent(in) :: & IPcoords0, & NodeCoords0 integer, optional, intent(in) :: & @@ -78,7 +78,7 @@ end subroutine discretization_init !-------------------------------------------------------------------------------------------------- subroutine discretization_result() - real(pReal), dimension(:,:), allocatable :: u + real(pREAL), dimension(:,:), allocatable :: u call result_closeGroup(result_addGroup('current/geometry')) @@ -98,7 +98,7 @@ end subroutine discretization_result !-------------------------------------------------------------------------------------------------- subroutine discretization_setIPcoords(IPcoords) - real(pReal), dimension(:,:), intent(in) :: IPcoords + real(pREAL), dimension(:,:), intent(in) :: IPcoords discretization_IPcoords = IPcoords @@ -110,7 +110,7 @@ end subroutine discretization_setIPcoords !-------------------------------------------------------------------------------------------------- subroutine discretization_setNodeCoords(NodeCoords) - real(pReal), dimension(:,:), intent(in) :: NodeCoords + real(pREAL), dimension(:,:), intent(in) :: NodeCoords discretization_NodeCoords = NodeCoords diff --git a/src/geometry_plastic_nonlocal.f90 b/src/geometry_plastic_nonlocal.f90 index e9e7a19cc..c3a6ef7b1 100644 --- a/src/geometry_plastic_nonlocal.f90 +++ b/src/geometry_plastic_nonlocal.f90 @@ -18,13 +18,13 @@ module geometry_plastic_nonlocal integer, dimension(:,:,:,:), allocatable, protected :: & geometry_plastic_nonlocal_IPneighborhood !< 6 or less neighboring IPs as [element ID, IP ID, face ID that point to me] - real(pReal), dimension(:,:), allocatable, protected :: & + real(pREAL), dimension(:,:), allocatable, protected :: & geometry_plastic_nonlocal_IPvolume0 !< volume associated with IP (initially!) - real(pReal), dimension(:,:,:), allocatable, protected :: & + real(pREAL), dimension(:,:,:), allocatable, protected :: & geometry_plastic_nonlocal_IParea0 !< area of interface to neighboring IP (initially!) - real(pReal), dimension(:,:,:,:), allocatable, protected :: & + real(pREAL), dimension(:,:,:,:), allocatable, protected :: & geometry_plastic_nonlocal_IPareaNormal0 !< area normal of interface to neighboring IP (initially!) @@ -54,7 +54,7 @@ end subroutine geometry_plastic_nonlocal_setIPneighborhood !--------------------------------------------------------------------------------------------------- subroutine geometry_plastic_nonlocal_setIPvolume(IPvolume) - real(pReal), dimension(:,:), intent(in) :: IPvolume + real(pREAL), dimension(:,:), intent(in) :: IPvolume geometry_plastic_nonlocal_IPvolume0 = IPvolume @@ -67,7 +67,7 @@ end subroutine geometry_plastic_nonlocal_setIPvolume !--------------------------------------------------------------------------------------------------- subroutine geometry_plastic_nonlocal_setIParea(IParea) - real(pReal), dimension(:,:,:), intent(in) :: IParea + real(pREAL), dimension(:,:,:), intent(in) :: IParea geometry_plastic_nonlocal_IParea0 = IParea @@ -80,7 +80,7 @@ end subroutine geometry_plastic_nonlocal_setIParea !--------------------------------------------------------------------------------------------------- subroutine geometry_plastic_nonlocal_setIPareaNormal(IPareaNormal) - real(pReal), dimension(:,:,:,:), intent(in) :: IPareaNormal + real(pREAL), dimension(:,:,:,:), intent(in) :: IPareaNormal geometry_plastic_nonlocal_IPareaNormal0 = IPareaNormal @@ -117,7 +117,7 @@ subroutine geometry_plastic_nonlocal_result() call result_openJobFile() writeVolume: block - real(pReal), dimension(:), allocatable :: temp + real(pREAL), dimension(:), allocatable :: temp shp = shape(geometry_plastic_nonlocal_IPvolume0) temp = reshape(geometry_plastic_nonlocal_IPvolume0,[shp(1)*shp(2)]) call result_writeDataset(temp,'geometry','v_0',& @@ -125,7 +125,7 @@ subroutine geometry_plastic_nonlocal_result() end block writeVolume writeAreas: block - real(pReal), dimension(:,:), allocatable :: temp + real(pREAL), dimension(:,:), allocatable :: temp shp = shape(geometry_plastic_nonlocal_IParea0) temp = reshape(geometry_plastic_nonlocal_IParea0,[shp(1),shp(2)*shp(3)]) call result_writeDataset(temp,'geometry','a_0',& @@ -133,7 +133,7 @@ subroutine geometry_plastic_nonlocal_result() end block writeAreas writeNormals: block - real(pReal), dimension(:,:,:), allocatable :: temp + real(pREAL), dimension(:,:,:), allocatable :: temp shp = shape(geometry_plastic_nonlocal_IPareaNormal0) temp = reshape(geometry_plastic_nonlocal_IPareaNormal0,[shp(1),shp(2),shp(3)*shp(4)]) call result_writeDataset(temp,'geometry','n_0',& diff --git a/src/grid/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 index 0fccdf548..867fb2145 100644 --- a/src/grid/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -40,7 +40,7 @@ program DAMASK_grid type(tRotation) :: rot !< rotation of BC type(tBoundaryCondition) :: stress, & !< stress BC deformation !< deformation BC (dot_F, F, or L) - real(pReal) :: t, & !< length of increment + real(pREAL) :: t, & !< length of increment r !< ratio of geometric progression integer :: N, & !< number of increments f_out, & !< frequency of result writes @@ -63,12 +63,12 @@ program DAMASK_grid ! loop variables, convergence etc. integer, parameter :: & subStepFactor = 2 !< for each substep, divide the last time increment by 2.0 - real(pReal) :: & - t = 0.0_pReal, & !< elapsed time - t_0 = 0.0_pReal, & !< begin of interval - Delta_t = 1.0_pReal, & !< current time interval - Delta_t_prev = 0.0_pReal, & !< previous time interval - t_remaining = 0.0_pReal !< remaining time of current load case + real(pREAL) :: & + t = 0.0_pREAL, & !< elapsed time + t_0 = 0.0_pREAL, & !< begin of interval + Delta_t = 1.0_pREAL, & !< current time interval + Delta_t_prev = 0.0_pREAL, & !< previous time interval + t_remaining = 0.0_pREAL !< remaining time of current load case logical :: & guess, & !< guess along former trajectory stagIterate, & @@ -234,14 +234,14 @@ program DAMASK_grid call getMaskedTensor(loadCases(l)%stress%values,loadCases(l)%stress%mask,step_mech%get_list(m)) #endif end select - call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dReal('R',defaultVal = real([0.0,0.0,1.0,0.0],pReal)),degrees=.true.) + call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dReal('R',defaultVal = real([0.0,0.0,1.0,0.0],pREAL)),degrees=.true.) end do readMech if (.not. allocated(loadCases(l)%deformation%myType)) call IO_error(error_ID=837,ext_msg = 'L/dot_F/F missing') step_discretization => load_step%get_dict('discretization') loadCases(l)%t = step_discretization%get_asReal('t') loadCases(l)%N = step_discretization%get_asInt ('N') - loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pReal) + loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pREAL) loadCases(l)%f_restart = load_step%get_asInt('f_restart', defaultVal=huge(0)) if (load_step%get_asStr('f_out',defaultVal='n/a') == 'none') then @@ -279,7 +279,7 @@ program DAMASK_grid if (loadCases(l)%stress%mask(i,j)) then write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' else - write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pReal + write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pREAL end if end do; write(IO_STDOUT,'(/)',advance='no') end do @@ -288,13 +288,13 @@ program DAMASK_grid write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',& transpose(loadCases(l)%rot%asMatrix()) - if (loadCases(l)%r <= 0.0_pReal) errorID = 833 - if (loadCases(l)%t < 0.0_pReal) errorID = 834 + if (loadCases(l)%r <= 0.0_pREAL) errorID = 833 + if (loadCases(l)%t < 0.0_pREAL) errorID = 834 if (loadCases(l)%N < 1) errorID = 835 if (loadCases(l)%f_out < 1) errorID = 836 if (loadCases(l)%f_restart < 1) errorID = 839 - if (dEq(loadCases(l)%r,1.0_pReal,1.e-9_pReal)) then + if (dEq(loadCases(l)%r,1.0_pREAL,1.e-9_pREAL)) then print'(2x,a)', 'r: 1 (constant step width)' else print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r @@ -345,7 +345,7 @@ program DAMASK_grid writeUndeformed: if (CLI_restartInc < 1) then print'(/,1x,a)', '... writing initial configuration to file .................................' flush(IO_STDOUT) - call materialpoint_result(0,0.0_pReal) + call materialpoint_result(0,0.0_pREAL) end if writeUndeformed loadCaseLooping: do l = 1, size(loadCases) @@ -358,13 +358,13 @@ program DAMASK_grid !-------------------------------------------------------------------------------------------------- ! forwarding time Delta_t_prev = Delta_t ! last time intervall that brought former inc to an end - if (dEq(loadCases(l)%r,1.0_pReal,1.e-9_pReal)) then ! linear scale - Delta_t = loadCases(l)%t/real(loadCases(l)%N,pReal) + if (dEq(loadCases(l)%r,1.0_pREAL,1.e-9_pREAL)) then ! linear scale + Delta_t = loadCases(l)%t/real(loadCases(l)%N,pREAL) else Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) & - / (1.0_pReal-loadCases(l)%r**loadCases(l)%N) + / (1.0_pREAL-loadCases(l)%r**loadCases(l)%N) end if - Delta_t = Delta_t * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step + Delta_t = Delta_t * real(subStepFactor,pREAL)**real(-cutBackLevel,pREAL) ! depending on cut back level, decrease time step skipping: if (totalIncsCounter <= CLI_restartInc) then ! not yet at restart inc? t = t + Delta_t ! just advance time, skip already performed calculation @@ -450,7 +450,7 @@ program DAMASK_grid stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator cutBackLevel = cutBackLevel + 1 t = t - Delta_t - Delta_t = Delta_t/real(subStepFactor,pReal) ! cut timestep + Delta_t = Delta_t/real(subStepFactor,pREAL) ! cut timestep print'(/,1x,a)', 'cutting back ' else ! no more options to continue if (worldrank == 0) close(statUnit) @@ -513,7 +513,7 @@ contains subroutine getMaskedTensor(values,mask,tensor) - real(pReal), intent(out), dimension(3,3) :: values + real(pREAL), intent(out), dimension(3,3) :: values logical, intent(out), dimension(3,3) :: mask type(tList), pointer :: tensor @@ -521,7 +521,7 @@ subroutine getMaskedTensor(values,mask,tensor) integer :: i,j - values = 0.0_pReal + values = 0.0_pREAL do i = 1,3 row => tensor%get_list(i) do j = 1,3 diff --git a/src/grid/VTI.f90 b/src/grid/VTI.f90 index ca166c042..2749c1bb6 100644 --- a/src/grid/VTI.f90 +++ b/src/grid/VTI.f90 @@ -50,7 +50,7 @@ function VTI_readDataset_real(fileContent,label) result(dataset) character(len=*), intent(in) :: & label, & fileContent - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & dataset character(len=:), allocatable :: dataType, headerType, base64Str @@ -143,7 +143,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, & integer, dimension(3), intent(out) :: & cells ! # of cells (across all processes!) - real(pReal), dimension(3), intent(out) :: & + real(pREAL), dimension(3), intent(out) :: & geomSize, & ! size (across all processes!) origin ! origin (across all processes!) character(len=*), intent(in) :: & @@ -156,7 +156,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, & cells = -1 - geomSize = -1.0_pReal + geomSize = -1.0_pREAL inFile = .false. inImage = .false. @@ -198,11 +198,11 @@ end subroutine VTI_readCellsSizeOrigin subroutine cellsSizeOrigin(c,s,o,header) integer, dimension(3), intent(out) :: c - real(pReal), dimension(3), intent(out) :: s,o + real(pREAL), dimension(3), intent(out) :: s,o character(len=*), intent(in) :: header character(len=:), allocatable :: temp - real(pReal), dimension(3) :: delta + real(pREAL), dimension(3) :: delta integer :: i @@ -217,7 +217,7 @@ subroutine cellsSizeOrigin(c,s,o,header) temp = getXMLValue(header,'Spacing') delta = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] - s = delta * real(c,pReal) + s = delta * real(c,pREAL) temp = getXMLValue(header,'Origin') o = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] @@ -255,7 +255,7 @@ end function as_Int !-------------------------------------------------------------------------------------------------- -!> @brief Interpret Base64 string in vtk XML file as real of kind pReal. +!> @brief Interpret Base64 string in vtk XML file as real of kind pREAL. !-------------------------------------------------------------------------------------------------- function as_real(base64Str,headerType,compressed,dataType) @@ -264,18 +264,18 @@ function as_real(base64Str,headerType,compressed,dataType) dataType ! data type (Int32, Int64, Float32, Float64) logical, intent(in) :: compressed ! indicate whether data is zlib compressed - real(pReal), dimension(:), allocatable :: as_real + real(pREAL), dimension(:), allocatable :: as_real select case(dataType) case('Int32') - as_real = real(prec_bytesToC_INT32_T(asBytes(base64Str,headerType,compressed)),pReal) + as_real = real(prec_bytesToC_INT32_T(asBytes(base64Str,headerType,compressed)),pREAL) case('Int64') - as_real = real(prec_bytesToC_INT64_T(asBytes(base64Str,headerType,compressed)),pReal) + as_real = real(prec_bytesToC_INT64_T(asBytes(base64Str,headerType,compressed)),pREAL) case('Float32') - as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pReal) + as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pREAL) case('Float64') - as_real = real(prec_bytesToC_DOUBLE (asBytes(base64Str,headerType,compressed)),pReal) + as_real = real(prec_bytesToC_DOUBLE (asBytes(base64Str,headerType,compressed)),pREAL) case default call IO_error(844,ext_msg='unknown data type: '//trim(dataType)) end select diff --git a/src/grid/discretization_grid.f90 b/src/grid/discretization_grid.f90 index ee44f5907..f2f9ca126 100644 --- a/src/grid/discretization_grid.f90 +++ b/src/grid/discretization_grid.f90 @@ -35,9 +35,9 @@ module discretization_grid integer, public, protected :: & cells3, & !< (local) cells in 3rd direction cells3Offset !< (local) cells offset in 3rd direction - real(pReal), dimension(3), public, protected :: & + real(pREAL), dimension(3), public, protected :: & geomSize !< (global) physical size - real(pReal), public, protected :: & + real(pREAL), public, protected :: & size3, & !< (local) size in 3rd direction size3offset !< (local) size offset in 3rd direction @@ -55,7 +55,7 @@ subroutine discretization_grid_init(restart) logical, intent(in) :: restart - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & mySize, & !< domain size of this process origin !< (global) distance to origin integer, dimension(3) :: & @@ -119,8 +119,8 @@ subroutine discretization_grid_init(restart) cells3 = int(z) cells3Offset = int(z_offset) - size3 = geomSize(3)*real(cells3,pReal) /real(cells(3),pReal) - size3Offset = geomSize(3)*real(cells3Offset,pReal)/real(cells(3),pReal) + size3 = geomSize(3)*real(cells3,pREAL) /real(cells(3),pREAL) + size3Offset = geomSize(3)*real(cells3Offset,pREAL)/real(cells(3),pREAL) myGrid = [cells(1:2),cells3] mySize = [geomSize(1:2),size3] @@ -156,7 +156,7 @@ subroutine discretization_grid_init(restart) !-------------------------------------------------------------------------------------------------- ! geometry information required by the nonlocal CP model - call geometry_plastic_nonlocal_setIPvolume(reshape([(product(mySize/real(myGrid,pReal)),j=1,product(myGrid))], & + call geometry_plastic_nonlocal_setIPvolume(reshape([(product(mySize/real(myGrid,pREAL)),j=1,product(myGrid))], & [1,product(myGrid)])) call geometry_plastic_nonlocal_setIParea (cellSurfaceArea(mySize,myGrid)) call geometry_plastic_nonlocal_setIPareaNormal (cellSurfaceNormal(product(myGrid))) @@ -171,10 +171,10 @@ end subroutine discretization_grid_init function IPcoordinates0(cells,geomSize,cells3Offset) integer, dimension(3), intent(in) :: cells ! cells (for this process!) - real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!) integer, intent(in) :: cells3Offset ! cells(3) offset - real(pReal), dimension(3,product(cells)) :: ipCoordinates0 + real(pREAL), dimension(3,product(cells)) :: ipCoordinates0 integer :: & a,b,c, & @@ -184,7 +184,7 @@ function IPcoordinates0(cells,geomSize,cells3Offset) i = 0 do c = 1, cells(3); do b = 1, cells(2); do a = 1, cells(1) i = i + 1 - IPcoordinates0(1:3,i) = geomSize/real(cells,pReal) * (real([a,b,cells3Offset+c],pReal) -0.5_pReal) + IPcoordinates0(1:3,i) = geomSize/real(cells,pREAL) * (real([a,b,cells3Offset+c],pREAL) -0.5_pREAL) end do; end do; end do end function IPcoordinates0 @@ -196,10 +196,10 @@ end function IPcoordinates0 pure function nodes0(cells,geomSize,cells3Offset) integer, dimension(3), intent(in) :: cells ! cells (for this process!) - real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!) integer, intent(in) :: cells3Offset ! cells(3) offset - real(pReal), dimension(3,product(cells+1)) :: nodes0 + real(pREAL), dimension(3,product(cells+1)) :: nodes0 integer :: & a,b,c, & @@ -208,7 +208,7 @@ pure function nodes0(cells,geomSize,cells3Offset) n = 0 do c = 0, cells3; do b = 0, cells(2); do a = 0, cells(1) n = n + 1 - nodes0(1:3,n) = geomSize/real(cells,pReal) * real([a,b,cells3Offset+c],pReal) + nodes0(1:3,n) = geomSize/real(cells,pREAL) * real([a,b,cells3Offset+c],pREAL) end do; end do; end do end function nodes0 @@ -219,15 +219,15 @@ end function nodes0 !-------------------------------------------------------------------------------------------------- pure function cellSurfaceArea(geomSize,cells) - real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!) integer, dimension(3), intent(in) :: cells ! cells (for this process!) - real(pReal), dimension(6,1,product(cells)) :: cellSurfaceArea + real(pREAL), dimension(6,1,product(cells)) :: cellSurfaceArea - cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2),pReal) * geomSize(3)/real(cells(3),pReal) - cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3),pReal) * geomSize(1)/real(cells(1),pReal) - cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1),pReal) * geomSize(2)/real(cells(2),pReal) + cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2),pREAL) * geomSize(3)/real(cells(3),pREAL) + cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3),pREAL) * geomSize(1)/real(cells(1),pREAL) + cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1),pREAL) * geomSize(2)/real(cells(2),pREAL) end function cellSurfaceArea @@ -239,14 +239,14 @@ pure function cellSurfaceNormal(nElems) integer, intent(in) :: nElems - real(pReal), dimension(3,6,1,nElems) :: cellSurfaceNormal + real(pREAL), dimension(3,6,1,nElems) :: cellSurfaceNormal - cellSurfaceNormal(1:3,1,1,:) = spread([+1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) - cellSurfaceNormal(1:3,2,1,:) = spread([-1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) - cellSurfaceNormal(1:3,3,1,:) = spread([ 0.0_pReal,+1.0_pReal, 0.0_pReal],2,nElems) - cellSurfaceNormal(1:3,4,1,:) = spread([ 0.0_pReal,-1.0_pReal, 0.0_pReal],2,nElems) - cellSurfaceNormal(1:3,5,1,:) = spread([ 0.0_pReal, 0.0_pReal,+1.0_pReal],2,nElems) - cellSurfaceNormal(1:3,6,1,:) = spread([ 0.0_pReal, 0.0_pReal,-1.0_pReal],2,nElems) + cellSurfaceNormal(1:3,1,1,:) = spread([+1.0_pREAL, 0.0_pREAL, 0.0_pREAL],2,nElems) + cellSurfaceNormal(1:3,2,1,:) = spread([-1.0_pREAL, 0.0_pREAL, 0.0_pREAL],2,nElems) + cellSurfaceNormal(1:3,3,1,:) = spread([ 0.0_pREAL,+1.0_pREAL, 0.0_pREAL],2,nElems) + cellSurfaceNormal(1:3,4,1,:) = spread([ 0.0_pREAL,-1.0_pREAL, 0.0_pREAL],2,nElems) + cellSurfaceNormal(1:3,5,1,:) = spread([ 0.0_pREAL, 0.0_pREAL,+1.0_pREAL],2,nElems) + cellSurfaceNormal(1:3,6,1,:) = spread([ 0.0_pREAL, 0.0_pREAL,-1.0_pREAL],2,nElems) end function cellSurfaceNormal @@ -314,9 +314,9 @@ end function IPneighborhood function discretization_grid_getInitialCondition(label) result(ic) character(len=*), intent(in) :: label - real(pReal), dimension(cells(1),cells(2),cells3) :: ic + real(pREAL), dimension(cells(1),cells(2),cells3) :: ic - real(pReal), dimension(:), allocatable :: ic_global, ic_local + real(pREAL), dimension(:), allocatable :: ic_global, ic_local integer(MPI_INTEGER_KIND) :: err_MPI integer, dimension(worldsize) :: & diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index 0e0e36f3e..9fce4a2f3 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -35,7 +35,7 @@ module grid_damage_spectral type :: tNumerics integer :: & itmax !< maximum number of iterations - real(pReal) :: & + real(pREAL) :: & phi_min, & !< non-zero residual damage eps_damage_atol, & !< absolute tolerance for damage evolution eps_damage_rtol !< relative tolerance for damage evolution @@ -48,7 +48,7 @@ module grid_damage_spectral ! PETSc data SNES :: SNES_damage Vec :: solution_vec - real(pReal), dimension(:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:), allocatable :: & phi, & !< field of current damage phi_lastInc, & !< field of previous damage phi_stagInc !< field of staggered damage @@ -56,8 +56,8 @@ module grid_damage_spectral !-------------------------------------------------------------------------------------------------- ! reference diffusion tensor, mobility etc. integer :: totalIter = 0 !< total iteration in current increment - real(pReal), dimension(3,3) :: K_ref - real(pReal) :: mu_ref + real(pREAL), dimension(3,3) :: K_ref + real(pREAL) :: mu_ref public :: & grid_damage_spectral_init, & @@ -75,12 +75,12 @@ subroutine grid_damage_spectral_init() PetscInt, dimension(0:worldsize-1) :: localK integer :: i, j, k, ce DM :: damage_grid - real(pReal), dimension(:,:,:), pointer :: phi_PETSc + real(pREAL), dimension(:,:,:), pointer :: phi_PETSc Vec :: uBound, lBound integer(MPI_INTEGER_KIND) :: err_MPI PetscErrorCode :: err_PETSc integer(HID_T) :: fileHandle, groupHandle - real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN + real(pREAL), dimension(1,product(cells(1:2))*cells3) :: tempN type(tDict), pointer :: & num_grid, & num_generic @@ -98,16 +98,16 @@ subroutine grid_damage_spectral_init() ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) - num%eps_damage_atol = num_grid%get_asReal ('eps_damage_atol',defaultVal=1.0e-2_pReal) - num%eps_damage_rtol = num_grid%get_asReal ('eps_damage_rtol',defaultVal=1.0e-6_pReal) + num%eps_damage_atol = num_grid%get_asReal ('eps_damage_atol',defaultVal=1.0e-2_pREAL) + num%eps_damage_rtol = num_grid%get_asReal ('eps_damage_rtol',defaultVal=1.0e-6_pREAL) num_generic => config_numerics%get_dict('generic',defaultVal=emptyDict) - num%phi_min = num_generic%get_asReal('phi_min', defaultVal=1.0e-6_pReal) + num%phi_min = num_generic%get_asReal('phi_min', defaultVal=1.0e-6_pREAL) - if (num%phi_min < 0.0_pReal) call IO_error(301,ext_msg='phi_min') + if (num%phi_min < 0.0_pREAL) call IO_error(301,ext_msg='phi_min') if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') - if (num%eps_damage_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_damage_atol') - if (num%eps_damage_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_damage_rtol') + if (num%eps_damage_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_damage_atol') + if (num%eps_damage_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_damage_rtol') !-------------------------------------------------------------------------------------------------- ! set default and user defined options for PETSc @@ -162,9 +162,9 @@ subroutine grid_damage_spectral_init() CHKERRQ(err_PETSc) call DMGetGlobalVector(damage_grid,uBound,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(lBound,0.0_pReal,err_PETSc) + call VecSet(lBound,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(uBound,1.0_pReal,err_PETSc) + call VecSet(uBound,1.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) call SNESVISetVariableBounds(SNES_damage,lBound,uBound,err_PETSc) ! variable bounds for variational inequalities CHKERRQ(err_PETSc) @@ -208,7 +208,7 @@ end subroutine grid_damage_spectral_init !-------------------------------------------------------------------------------------------------- function grid_damage_spectral_solution(Delta_t) result(solution) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t !< increment in time for current solution integer :: i, j, k, ce type(tSolutionState) :: solution @@ -275,7 +275,7 @@ subroutine grid_damage_spectral_forward(cutBack) integer :: i, j, k, ce DM :: dm_local - real(pReal), dimension(:,:,:), pointer :: phi_PETSc + real(pREAL), dimension(:,:,:), pointer :: phi_PETSc PetscErrorCode :: err_PETSc @@ -341,15 +341,15 @@ subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc) DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & residual_subdomain - real(pReal), dimension(cells(1),cells(2),cells3), intent(in) :: & + real(pREAL), dimension(cells(1),cells(2),cells3), intent(in) :: & x_scal - real(pReal), dimension(cells(1),cells(2),cells3), intent(out) :: & + real(pREAL), dimension(cells(1),cells(2),cells3), intent(out) :: & r !< residual PetscObject :: dummy PetscErrorCode, intent(out) :: err_PETSc integer :: i, j, k, ce - real(pReal), dimension(3,cells(1),cells(2),cells3) :: vectorField + real(pREAL), dimension(3,cells(1),cells(2),cells3) :: vectorField phi = x_scal @@ -384,8 +384,8 @@ subroutine updateReference() integer(MPI_INTEGER_KIND) :: err_MPI - K_ref = 0.0_pReal - mu_ref = 0.0_pReal + K_ref = 0.0_pREAL + mu_ref = 0.0_pREAL do ce = 1, product(cells(1:2))*cells3 K_ref = K_ref + homogenization_K_phi(ce) mu_ref = mu_ref + homogenization_mu_phi(ce) diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index 70809f2d1..1f2aec682 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -41,7 +41,7 @@ module grid_mechanical_FEM integer :: & itmin, & !< minimum number of iterations itmax !< maximum number of iterations - real(pReal) :: & + real(pREAL) :: & eps_div_atol, & !< absolute tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC @@ -58,27 +58,27 @@ module grid_mechanical_FEM !-------------------------------------------------------------------------------------------------- ! common pointwise data - real(pReal), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc - real(pReal) :: detJ - real(pReal), dimension(3) :: delta - real(pReal), dimension(3,8) :: BMat - real(pReal), dimension(8,8) :: HGMat + real(pREAL), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc + real(pREAL) :: detJ + real(pREAL), dimension(3) :: delta + real(pREAL), dimension(3,8) :: BMat + real(pREAL), dimension(8,8) :: HGMat !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - real(pReal), dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + real(pREAL), dimension(3,3) :: & + F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient - P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress - P_aim = 0.0_pReal + P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress + P_aim = 0.0_pREAL character(len=:), allocatable :: incInfo !< time and increment information - real(pReal), dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - S = 0.0_pReal !< current compliance (filled up with zeros) + real(pREAL), dimension(3,3,3,3) :: & + C_volAvg = 0.0_pREAL, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness + S = 0.0_pREAL !< current compliance (filled up with zeros) - real(pReal) :: & + real(pREAL) :: & err_BC !< deviation from stress BC integer :: & @@ -98,19 +98,19 @@ contains !-------------------------------------------------------------------------------------------------- subroutine grid_mechanical_FEM_init - real(pReal), parameter :: HGCoeff = 0.0e-2_pReal - real(pReal), parameter, dimension(4,8) :: & - HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) - real(pReal), dimension(3,3,3,3) :: devNull - real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n - real(pReal), dimension(3,product(cells(1:2))*cells3) :: temp3n + real(pREAL), parameter :: HGCoeff = 0.0e-2_pREAL + real(pREAL), parameter, dimension(4,8) :: & + HGcomp = reshape([ 1.0_pREAL, 1.0_pREAL, 1.0_pREAL,-1.0_pREAL, & + 1.0_pREAL,-1.0_pREAL,-1.0_pREAL, 1.0_pREAL, & + -1.0_pREAL, 1.0_pREAL,-1.0_pREAL, 1.0_pREAL, & + -1.0_pREAL,-1.0_pREAL, 1.0_pREAL,-1.0_pREAL, & + -1.0_pREAL,-1.0_pREAL, 1.0_pREAL, 1.0_pREAL, & + -1.0_pREAL, 1.0_pREAL,-1.0_pREAL,-1.0_pREAL, & + 1.0_pREAL,-1.0_pREAL,-1.0_pREAL,-1.0_pREAL, & + 1.0_pREAL, 1.0_pREAL, 1.0_pREAL, 1.0_pREAL], [4,8]) + real(pREAL), dimension(3,3,3,3) :: devNull + real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n + real(pREAL), dimension(3,product(cells(1:2))*cells3) :: temp3n PetscErrorCode :: err_PETSc integer(MPI_INTEGER_KIND) :: err_MPI PetscScalar, pointer, dimension(:,:,:,:) :: & @@ -129,17 +129,17 @@ subroutine grid_mechanical_FEM_init ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) - num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL) num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) - if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' - if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' - if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' - if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' + if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol' + if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol' + if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol' + if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' @@ -157,9 +157,9 @@ subroutine grid_mechanical_FEM_init !-------------------------------------------------------------------------------------------------- ! allocate global fields - allocate(F (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(P_current (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) + allocate(F (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(P_current (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -184,7 +184,7 @@ subroutine grid_mechanical_FEM_init CHKERRQ(err_PETSc) call DMsetUp(mechanical_grid,err_PETSc) CHKERRQ(err_PETSc) - call DMDASetUniformCoordinates(mechanical_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),err_PETSc) + call DMDASetUniformCoordinates(mechanical_grid,0.0_pREAL,geomSize(1),0.0_pREAL,geomSize(2),0.0_pREAL,geomSize(3),err_PETSc) CHKERRQ(err_PETSc) call DMCreateGlobalVector(mechanical_grid,solution_current,err_PETSc) CHKERRQ(err_PETSc) @@ -207,18 +207,18 @@ subroutine grid_mechanical_FEM_init !-------------------------------------------------------------------------------------------------- ! init fields - call VecSet(solution_current,0.0_pReal,err_PETSc) + call VecSet(solution_current,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(solution_lastInc,0.0_pReal,err_PETSc) + call VecSet(solution_lastInc,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(solution_rate ,0.0_pReal,err_PETSc) + call VecSet(solution_rate ,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) call DMDAVecGetArrayF90(mechanical_grid,solution_current,u,err_PETSc) CHKERRQ(err_PETSc) call DMDAVecGetArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc) CHKERRQ(err_PETSc) - delta = geomSize/real(cells,pReal) ! grid spacing + delta = geomSize/real(cells,pREAL) ! grid spacing detJ = product(delta) ! cell volume BMat = reshape(real([-delta(1)**(-1),-delta(2)**(-1),-delta(3)**(-1), & @@ -228,10 +228,10 @@ subroutine grid_mechanical_FEM_init -delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), & delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), & -delta(1)**(-1), delta(2)**(-1), delta(3)**(-1), & - delta(1)**(-1), delta(2)**(-1), delta(3)**(-1)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix + delta(1)**(-1), delta(2)**(-1), delta(3)**(-1)],pREAL), [3,8])/4.0_pREAL ! shape function derivative matrix HGMat = matmul(transpose(HGcomp),HGcomp) & - * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix + * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pREAL ! hourglass stabilization matrix !-------------------------------------------------------------------------------------------------- ! init fields @@ -271,7 +271,7 @@ subroutine grid_mechanical_FEM_init call utilities_updateCoords(F) call utilities_constitutiveResponse(P_current,P_av,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 F, & ! target F - 0.0_pReal) ! time increment + 0.0_pREAL) ! time increment call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc) CHKERRQ(err_PETSc) call DMDAVecRestoreArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc) @@ -340,7 +340,7 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai logical, intent(in) :: & cutBack, & guess - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t_old, & Delta_t, & t_remaining !< remaining time of current load case @@ -365,29 +365,29 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai else C_volAvgLastInc = C_volAvg - F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components + F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components F_aim_lastInc = F_aim !----------------------------------------------------------------------------------------------- ! calculate rate for aim if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F F_aimDot = F_aimDot & - + matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask) elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) end if if (guess) then - call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,err_PETSc) + call VecWAXPY(solution_rate,-1.0_pREAL,solution_lastInc,solution_current,err_PETSc) CHKERRQ(err_PETSc) - call VecScale(solution_rate,1.0_pReal/Delta_t_old,err_PETSc) + call VecScale(solution_rate,1.0_pREAL/Delta_t_old,err_PETSc) CHKERRQ(err_PETSc) else - call VecSet(solution_rate,0.0_pReal,err_PETSc) + call VecSet(solution_rate,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) end if call VecCopy(solution_current,solution_lastInc,err_PETSc) @@ -402,9 +402,9 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai ! update average and local deformation gradients F_aim = F_aim_lastInc + F_aimDot * Delta_t if (stress_BC%myType=='P') P_aim = P_aim & - + merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t if (stress_BC%myType=='dot_P') P_aim = P_aim & - + merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t call VecAXPY(solution_current,Delta_t,solution_rate,err_PETSc) CHKERRQ(err_PETSc) @@ -493,7 +493,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal) :: & + real(pREAL) :: & err_div, & divTol, & BCTol @@ -502,7 +502,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) - if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pReal)) & + if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pREAL)) & .or. terminallyIll) then reason = 1 elseif (totalIter >= num%itmax) then @@ -534,14 +534,14 @@ subroutine formResidual(da_local,x_local, & PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal), pointer,dimension(:,:,:,:) :: x_scal, r - real(pReal), dimension(8,3) :: x_elem, f_elem + real(pREAL), pointer,dimension(:,:,:,:) :: x_scal, r + real(pREAL), dimension(8,3) :: x_elem, f_elem PetscInt :: i, ii, j, jj, k, kk, ctr, ele PetscInt :: & PETScIter, & nfuncs integer(MPI_INTEGER_KIND) :: err_MPI - real(pReal), dimension(3,3,3,3) :: devNull + real(pREAL), dimension(3,3,3,3) :: devNull call SNESGetNumberFunctionEvals(SNES_mechanical,nfuncs,err_PETSc) CHKERRQ(err_PETSc) @@ -556,7 +556,7 @@ subroutine formResidual(da_local,x_local, & newIteration: if (totalIter <= PETScIter) then totalIter = totalIter + 1 print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter+1, '≤', num%itmax - if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & + if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & @@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, & !-------------------------------------------------------------------------------------------------- ! stress BC handling F_aim = F_aim - math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc - err_BC = maxval(abs(merge(.0_pReal,P_av - P_aim,params%stress_mask))) + err_BC = maxval(abs(merge(.0_pREAL,P_av - P_aim,params%stress_mask))) !-------------------------------------------------------------------------------------------------- ! constructing residual @@ -599,7 +599,7 @@ subroutine formResidual(da_local,x_local, & call DMDAVecGetArrayF90(da_local,x_local,x_scal,err_PETSc) CHKERRQ(err_PETSc) ele = 0 - r = 0.0_pReal + r = 0.0_pREAL do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1) ctr = 0 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 @@ -610,7 +610,7 @@ subroutine formResidual(da_local,x_local, & f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,i,j,k-cells3Offset)))*detJ + & matmul(HGMat,x_elem)*(homogenization_dPdF(1,1,1,1,ele) + & homogenization_dPdF(2,2,2,2,ele) + & - homogenization_dPdF(3,3,3,3,ele))/3.0_pReal + homogenization_dPdF(3,3,3,3,ele))/3.0_pREAL ctr = 0 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 ctr = ctr + 1 @@ -623,16 +623,16 @@ subroutine formResidual(da_local,x_local, & !-------------------------------------------------------------------------------------------------- ! applying boundary conditions if (cells3Offset == 0) then - r(0:2,0, 0, 0) = 0.0_pReal - r(0:2,cells(1),0, 0) = 0.0_pReal - r(0:2,0, cells(2),0) = 0.0_pReal - r(0:2,cells(1),cells(2),0) = 0.0_pReal + r(0:2,0, 0, 0) = 0.0_pREAL + r(0:2,cells(1),0, 0) = 0.0_pREAL + r(0:2,0, cells(2),0) = 0.0_pREAL + r(0:2,cells(1),cells(2),0) = 0.0_pREAL end if if (cells3+cells3Offset == cells(3)) then - r(0:2,0, 0, cells(3)) = 0.0_pReal - r(0:2,cells(1),0, cells(3)) = 0.0_pReal - r(0:2,0, cells(2),cells(3)) = 0.0_pReal - r(0:2,cells(1),cells(2),cells(3)) = 0.0_pReal + r(0:2,0, 0, cells(3)) = 0.0_pREAL + r(0:2,cells(1),0, cells(3)) = 0.0_pREAL + r(0:2,0, cells(2),cells(3)) = 0.0_pREAL + r(0:2,cells(1),cells(2),cells(3)) = 0.0_pREAL end if call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc) CHKERRQ(err_PETSc) @@ -652,17 +652,17 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc) PetscErrorCode :: err_PETSc MatStencil,dimension(4,24) :: row, col - real(pReal),pointer,dimension(:,:,:,:) :: x_scal - real(pReal),dimension(24,24) :: K_ele - real(pReal),dimension(9,24) :: BMatFull + real(pREAL),pointer,dimension(:,:,:,:) :: x_scal + real(pREAL),dimension(24,24) :: K_ele + real(pREAL),dimension(9,24) :: BMatFull PetscInt :: i, ii, j, jj, k, kk, ctr, ce PetscInt,dimension(3),parameter :: rows = [0, 1, 2] - real(pReal) :: diag + real(pREAL) :: diag MatNullSpace :: matnull Vec :: coordinates - BMatFull = 0.0_pReal + BMatFull = 0.0_pREAL BMatFull(1:3,1 :8 ) = BMat BMatFull(4:6,9 :16) = BMat BMatFull(7:9,17:24) = BMat @@ -692,16 +692,16 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc) end do; end do; end do row = col ce = ce + 1 - K_ele = 0.0_pReal + K_ele = 0.0_pREAL K_ele(1 :8 ,1 :8 ) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & homogenization_dPdF(2,2,2,2,ce) + & - homogenization_dPdF(3,3,3,3,ce))/3.0_pReal + homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL K_ele(9 :16,9 :16) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & homogenization_dPdF(2,2,2,2,ce) + & - homogenization_dPdF(3,3,3,3,ce))/3.0_pReal + homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL K_ele(17:24,17:24) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & homogenization_dPdF(2,2,2,2,ce) + & - homogenization_dPdF(3,3,3,3,ce))/3.0_pReal + homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL K_ele = K_ele + & matmul(transpose(BMatFull), & matmul(reshape(reshape(homogenization_dPdF(1:3,1:3,1:3,1:3,ce), & diff --git a/src/grid/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 index ac1fa1134..71ca438ac 100644 --- a/src/grid/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -40,7 +40,7 @@ module grid_mechanical_spectral_basic integer :: & itmin, & !< minimum number of iterations itmax !< maximum number of iterations - real(pReal) :: & + real(pREAL) :: & eps_div_atol, & !< absolute tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC @@ -57,28 +57,28 @@ module grid_mechanical_spectral_basic !-------------------------------------------------------------------------------------------------- ! common pointwise data - real(pReal), dimension(:,:,:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:,:,:), allocatable :: & F_lastInc, & !< field of previous compatible deformation gradients Fdot !< field of assumed rate of compatible deformation gradient !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - real(pReal), dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + real(pREAL), dimension(3,3) :: & + F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient - P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress - P_aim = 0.0_pReal + P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress + P_aim = 0.0_pREAL character(len=:), allocatable :: incInfo !< time and increment information - real(pReal), dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness - C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart) - S = 0.0_pReal !< current compliance (filled up with zeros) + real(pREAL), dimension(3,3,3,3) :: & + C_volAvg = 0.0_pREAL, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness + C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness + C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart) + S = 0.0_pREAL !< current compliance (filled up with zeros) - real(pReal) :: & + real(pREAL) :: & err_BC, & !< deviation from stress BC err_div !< RMS of div of P @@ -105,13 +105,13 @@ contains !-------------------------------------------------------------------------------------------------- subroutine grid_mechanical_spectral_basic_init() - real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: P + real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: P PetscErrorCode :: err_PETSc integer(MPI_INTEGER_KIND) :: err_MPI - real(pReal), pointer, dimension(:,:,:,:) :: & + real(pREAL), pointer, dimension(:,:,:,:) :: & F ! pointer to solution data PetscInt, dimension(0:worldsize-1) :: localK - real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n + real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n integer(HID_T) :: fileHandle, groupHandle type(tDict), pointer :: & num_grid @@ -132,17 +132,17 @@ subroutine grid_mechanical_spectral_basic_init() num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) - num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL) num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) - if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' - if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' - if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' - if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' + if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol' + if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol' + if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol' + if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' @@ -157,8 +157,8 @@ subroutine grid_mechanical_spectral_basic_init() !-------------------------------------------------------------------------------------------------- ! allocate global fields - allocate(F_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) + allocate(F_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -231,7 +231,7 @@ subroutine grid_mechanical_spectral_basic_init() call utilities_updateCoords(reshape(F,shape(F_lastInc))) call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 reshape(F,shape(F_lastInc)), & ! target F - 0.0_pReal) ! time increment + 0.0_pREAL) ! time increment call DMDAVecRestoreArrayF90(da,solution_vec,F,err_PETSc) ! deassociate pointer CHKERRQ(err_PETSc) @@ -305,7 +305,7 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_ logical, intent(in) :: & cutBack, & guess - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t_old, & Delta_t, & t_remaining !< remaining time of current load case @@ -315,7 +315,7 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_ type(tRotation), intent(in) :: & rotation_BC PetscErrorCode :: err_PETSc - real(pReal), pointer, dimension(:,:,:,:) :: F + real(pREAL), pointer, dimension(:,:,:,:) :: F call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) @@ -328,20 +328,20 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_ C_volAvgLastInc = C_volAvg C_minMaxAvgLastInc = C_minMaxAvg - F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components + F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components F_aim_lastInc = F_aim !----------------------------------------------------------------------------------------------- ! calculate rate for aim if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F F_aimDot = F_aimDot & - + matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask) elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) end if Fdot = utilities_calculateRate(guess, & @@ -356,9 +356,9 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_ ! update average and local deformation gradients F_aim = F_aim_lastInc + F_aimDot * Delta_t if (stress_BC%myType=='P') P_aim = P_aim & - + merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t if (stress_BC%myType=='dot_P') P_aim = P_aim & - + merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average rotation_BC%rotate(F_aim,active=.true.)),[9,cells(1),cells(2),cells3]) @@ -380,7 +380,7 @@ end subroutine grid_mechanical_spectral_basic_forward subroutine grid_mechanical_spectral_basic_updateCoords PetscErrorCode :: err_PETSc - real(pReal), dimension(:,:,:,:), pointer :: F + real(pREAL), dimension(:,:,:,:), pointer :: F call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) CHKERRQ(err_PETSc) @@ -398,7 +398,7 @@ subroutine grid_mechanical_spectral_basic_restartWrite PetscErrorCode :: err_PETSc integer(HID_T) :: fileHandle, groupHandle - real(pReal), dimension(:,:,:,:), pointer :: F + real(pREAL), dimension(:,:,:,:), pointer :: F call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) CHKERRQ(err_PETSc) @@ -448,14 +448,14 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal) :: & + real(pREAL) :: & divTol, & BCTol divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) - if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pReal)) & + if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pREAL)) & .or. terminallyIll) then reason = 1 elseif (totalIter >= num%itmax) then @@ -484,14 +484,14 @@ subroutine formResidual(residual_subdomain, F, & DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work) - real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: & + real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: & F !< deformation gradient field - real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(out) :: & + real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(out) :: & r !< residuum field PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & deltaF_aim PetscInt :: & PETScIter, & @@ -509,7 +509,7 @@ subroutine formResidual(residual_subdomain, F, & newIteration: if (totalIter <= PETScIter) then totalIter = totalIter + 1 print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax - if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & + if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & @@ -528,7 +528,7 @@ subroutine formResidual(residual_subdomain, F, & deltaF_aim = math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc F_aim = F_aim - deltaF_aim - err_BC = maxval(abs(merge(.0_pReal,P_av - P_aim,params%stress_mask))) + err_BC = maxval(abs(merge(.0_pREAL,P_av - P_aim,params%stress_mask))) r = utilities_GammaConvolution(r,params%rotation_BC%rotate(deltaF_aim,active=.true.)) diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 index 0cdb3a5e1..0210d1036 100644 --- a/src/grid/grid_mech_spectral_polarisation.f90 +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -40,14 +40,14 @@ module grid_mechanical_spectral_polarisation integer :: & itmin, & !< minimum number of iterations itmax !< maximum number of iterations - real(pReal) :: & + real(pREAL) :: & eps_div_atol, & !< absolute tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium eps_curl_atol, & !< absolute tolerance for compatibility eps_curl_rtol, & !< relative tolerance for compatibility eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC eps_stress_rtol !< relative tolerance for fullfillment of stress BC - real(pReal) :: & + real(pREAL) :: & alpha, & !< polarization scheme parameter 0.0 < alpha < 2.0. alpha = 1.0 ==> AL scheme, alpha = 2.0 ==> accelerated scheme beta !< polarization scheme parameter 0.0 < beta < 2.0. beta = 1.0 ==> AL scheme, beta = 2.0 ==> accelerated scheme end type tNumerics @@ -62,7 +62,7 @@ module grid_mechanical_spectral_polarisation !-------------------------------------------------------------------------------------------------- ! common pointwise data - real(pReal), dimension(:,:,:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:,:,:), allocatable :: & F_lastInc, & !< field of previous compatible deformation gradients F_tau_lastInc, & !< field of previous incompatible deformation gradient Fdot, & !< field of assumed rate of compatible deformation gradient @@ -70,25 +70,25 @@ module grid_mechanical_spectral_polarisation !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - real(pReal), dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + real(pREAL), dimension(3,3) :: & + F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient - F_av = 0.0_pReal, & !< average incompatible def grad field - P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress - P_aim = 0.0_pReal + F_av = 0.0_pREAL, & !< average incompatible def grad field + P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress + P_aim = 0.0_pREAL character(len=:), allocatable :: incInfo !< time and increment information - real(pReal), dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness - C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart) - S = 0.0_pReal, & !< current compliance (filled up with zeros) - C_scale = 0.0_pReal, & - S_scale = 0.0_pReal + real(pREAL), dimension(3,3,3,3) :: & + C_volAvg = 0.0_pREAL, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness + C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness + C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart) + S = 0.0_pREAL, & !< current compliance (filled up with zeros) + C_scale = 0.0_pREAL, & + S_scale = 0.0_pREAL - real(pReal) :: & + real(pREAL) :: & err_BC, & !< deviation from stress BC err_curl, & !< RMS of curl of F err_div !< RMS of div of P @@ -116,15 +116,15 @@ contains !-------------------------------------------------------------------------------------------------- subroutine grid_mechanical_spectral_polarisation_init() - real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: P + real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: P PetscErrorCode :: err_PETSc integer(MPI_INTEGER_KIND) :: err_MPI - real(pReal), pointer, dimension(:,:,:,:) :: & + real(pREAL), pointer, dimension(:,:,:,:) :: & FandF_tau, & ! overall pointer to solution data F, & ! specific (sub)pointer F_tau ! specific (sub)pointer PetscInt, dimension(0:worldsize-1) :: localK - real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n + real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n integer(HID_T) :: fileHandle, groupHandle type(tDict), pointer :: & num_grid @@ -143,27 +143,27 @@ subroutine grid_mechanical_spectral_polarisation_init() num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) - num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) - num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) - num%eps_curl_atol = num_grid%get_asReal('eps_curl_atol', defaultVal=1.0e-10_pReal) - num%eps_curl_rtol = num_grid%get_asReal('eps_curl_rtol', defaultVal=5.0e-4_pReal) - num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) - num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) + num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL) + num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL) + num%eps_curl_atol = num_grid%get_asReal('eps_curl_atol', defaultVal=1.0e-10_pREAL) + num%eps_curl_rtol = num_grid%get_asReal('eps_curl_rtol', defaultVal=5.0e-4_pREAL) + num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL) + num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL) num%itmin = num_grid%get_asInt ('itmin', defaultVal=1) num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) - num%alpha = num_grid%get_asReal('alpha', defaultVal=1.0_pReal) - num%beta = num_grid%get_asReal('beta', defaultVal=1.0_pReal) + num%alpha = num_grid%get_asReal('alpha', defaultVal=1.0_pREAL) + num%beta = num_grid%get_asReal('beta', defaultVal=1.0_pREAL) - if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' - if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' - if (num%eps_curl_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_atol' - if (num%eps_curl_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_rtol' - if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' - if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' + if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol' + if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol' + if (num%eps_curl_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_curl_atol' + if (num%eps_curl_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_curl_rtol' + if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol' + if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' - if (num%alpha <= 0.0_pReal .or. num%alpha > 2.0_pReal) extmsg = trim(extmsg)//' alpha' - if (num%beta < 0.0_pReal .or. num%beta > 2.0_pReal) extmsg = trim(extmsg)//' beta' + if (num%alpha <= 0.0_pREAL .or. num%alpha > 2.0_pREAL) extmsg = trim(extmsg)//' alpha' + if (num%beta < 0.0_pREAL .or. num%beta > 2.0_pREAL) extmsg = trim(extmsg)//' beta' if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg)) @@ -176,10 +176,10 @@ subroutine grid_mechanical_spectral_polarisation_init() !-------------------------------------------------------------------------------------------------- ! allocate global fields - allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(F_tau_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pReal) - allocate(F_tauDot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) + allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(F_tau_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) + allocate(F_tauDot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL) !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -252,15 +252,15 @@ subroutine grid_mechanical_spectral_polarisation_init() elseif (CLI_restartInc == 0) then restartRead F_lastInc = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3) ! initialize to identity F = reshape(F_lastInc,[9,cells(1),cells(2),cells3]) - F_tau = 2.0_pReal*F - F_tau_lastInc = 2.0_pReal*F_lastInc + F_tau = 2.0_pREAL*F + F_tau_lastInc = 2.0_pREAL*F_lastInc end if restartRead homogenization_F0 = reshape(F_lastInc, [3,3,product(cells(1:2))*cells3]) ! set starting condition for homogenization_mechanical_response call utilities_updateCoords(reshape(F,shape(F_lastInc))) call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 reshape(F,shape(F_lastInc)), & ! target F - 0.0_pReal) ! time increment + 0.0_pREAL) ! time increment call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,err_PETSc) ! deassociate pointer CHKERRQ(err_PETSc) @@ -340,7 +340,7 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D logical, intent(in) :: & cutBack, & guess - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t_old, & Delta_t, & t_remaining !< remaining time of current load case @@ -350,9 +350,9 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D type(tRotation), intent(in) :: & rotation_BC PetscErrorCode :: err_PETSc - real(pReal), pointer, dimension(:,:,:,:) :: FandF_tau, F, F_tau + real(pREAL), pointer, dimension(:,:,:,:) :: FandF_tau, F, F_tau integer :: i, j, k - real(pReal), dimension(3,3) :: F_lambda33 + real(pREAL), dimension(3,3) :: F_lambda33 call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) @@ -367,20 +367,20 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D C_volAvgLastInc = C_volAvg C_minMaxAvgLastInc = C_minMaxAvg - F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components + F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components F_aim_lastInc = F_aim !----------------------------------------------------------------------------------------------- ! calculate rate for aim if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F F_aimDot = F_aimDot & - + matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask) elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed F_aimDot = F_aimDot & - + merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) end if Fdot = utilities_calculateRate(guess, & @@ -399,9 +399,9 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D ! update average and local deformation gradients F_aim = F_aim_lastInc + F_aimDot * Delta_t if (stress_BC%myType=='P') P_aim = P_aim & - + merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t if (stress_BC%myType=='dot_P') P_aim = P_aim & - + merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average rotation_BC%rotate(F_aim,active=.true.)),& @@ -413,7 +413,7 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) F_lambda33 = math_I3 & - + math_mul3333xx33(S_scale,0.5_pReal*matmul(F_lambda33, & + + math_mul3333xx33(S_scale,0.5_pREAL*matmul(F_lambda33, & math_mul3333xx33(C_scale,matmul(transpose(F_lambda33),F_lambda33)-math_I3))) F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) end do; end do; end do @@ -437,7 +437,7 @@ end subroutine grid_mechanical_spectral_polarisation_forward subroutine grid_mechanical_spectral_polarisation_updateCoords PetscErrorCode :: err_PETSc - real(pReal), dimension(:,:,:,:), pointer :: FandF_tau + real(pREAL), dimension(:,:,:,:), pointer :: FandF_tau call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) CHKERRQ(err_PETSc) @@ -455,7 +455,7 @@ subroutine grid_mechanical_spectral_polarisation_restartWrite PetscErrorCode :: err_PETSc integer(HID_T) :: fileHandle, groupHandle - real(pReal), dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau + real(pREAL), dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) CHKERRQ(err_PETSc) @@ -509,7 +509,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal) :: & + real(pREAL) :: & curlTol, & divTol, & BCTol @@ -518,7 +518,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) - if ((totalIter >= num%itmin .and. all([err_div/divTol, err_curl/curlTol, err_BC/BCTol] < 1.0_pReal)) & + if ((totalIter >= num%itmin .and. all([err_div/divTol, err_curl/curlTol, err_BC/BCTol] < 1.0_pREAL)) & .or. terminallyIll) then reason = 1 elseif (totalIter >= num%itmax) then @@ -548,14 +548,14 @@ subroutine formResidual(residual_subdomain, FandF_tau, & r, dummy,err_PETSc) DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work) - real(pReal), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(in) :: & + real(pREAL), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(in) :: & FandF_tau !< deformation gradient field - real(pReal), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(out) :: & + real(pREAL), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(out) :: & r !< residuum field PetscObject :: dummy PetscErrorCode :: err_PETSc - real(pReal), pointer, dimension(:,:,:,:,:) :: & + real(pREAL), pointer, dimension(:,:,:,:,:) :: & F, & F_tau, & r_F, & @@ -587,7 +587,7 @@ subroutine formResidual(residual_subdomain, FandF_tau, & newIteration: if (totalIter <= PETScIter) then totalIter = totalIter + 1 print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax - if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & + if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index bfc5ccb5f..a0acbf822 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -35,7 +35,7 @@ module grid_thermal_spectral type :: tNumerics integer :: & itmax !< maximum number of iterations - real(pReal) :: & + real(pREAL) :: & eps_thermal_atol, & !< absolute tolerance for thermal equilibrium eps_thermal_rtol !< relative tolerance for thermal equilibrium end type tNumerics @@ -47,7 +47,7 @@ module grid_thermal_spectral ! PETSc data SNES :: SNES_thermal Vec :: solution_vec - real(pReal), dimension(:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:), allocatable :: & T, & !< field of current temperature T_lastInc, & !< field of previous temperature T_stagInc, & !< field of staggered temperature @@ -55,8 +55,8 @@ module grid_thermal_spectral !-------------------------------------------------------------------------------------------------- ! reference diffusion tensor, mobility etc. integer :: totalIter = 0 !< total iteration in current increment - real(pReal), dimension(3,3) :: K_ref - real(pReal) :: mu_ref + real(pREAL), dimension(3,3) :: K_ref + real(pREAL) :: mu_ref public :: & grid_thermal_spectral_init, & @@ -74,11 +74,11 @@ subroutine grid_thermal_spectral_init() PetscInt, dimension(0:worldsize-1) :: localK integer :: i, j, k, ce DM :: thermal_grid - real(pReal), dimension(:,:,:), pointer :: T_PETSc + real(pREAL), dimension(:,:,:), pointer :: T_PETSc integer(MPI_INTEGER_KIND) :: err_MPI PetscErrorCode :: err_PETSc integer(HID_T) :: fileHandle, groupHandle - real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN + real(pREAL), dimension(1,product(cells(1:2))*cells3) :: tempN type(tDict), pointer :: & num_grid @@ -93,12 +93,12 @@ subroutine grid_thermal_spectral_init() ! read numerical parameters and do sanity checks num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) - num%eps_thermal_atol = num_grid%get_asReal('eps_thermal_atol',defaultVal=1.0e-2_pReal) - num%eps_thermal_rtol = num_grid%get_asReal('eps_thermal_rtol',defaultVal=1.0e-6_pReal) + num%eps_thermal_atol = num_grid%get_asReal('eps_thermal_atol',defaultVal=1.0e-2_pREAL) + num%eps_thermal_rtol = num_grid%get_asReal('eps_thermal_rtol',defaultVal=1.0e-6_pREAL) if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') - if (num%eps_thermal_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_thermal_atol') - if (num%eps_thermal_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_thermal_rtol') + if (num%eps_thermal_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_thermal_atol') + if (num%eps_thermal_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_thermal_rtol') !-------------------------------------------------------------------------------------------------- ! set default and user defined options for PETSc @@ -113,7 +113,7 @@ subroutine grid_thermal_spectral_init() T = discretization_grid_getInitialCondition('T') T_lastInc = T T_stagInc = T - dotT_lastInc = 0.0_pReal * T + dotT_lastInc = 0.0_pREAL * T !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -165,7 +165,7 @@ subroutine grid_thermal_spectral_init() ce = 0 do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) ce = ce + 1 - call homogenization_thermal_setField(T(i,j,k),0.0_pReal,ce) + call homogenization_thermal_setField(T(i,j,k),0.0_pREAL,ce) end do; end do; end do call DMDAVecGetArrayF90(thermal_grid,solution_vec,T_PETSc,err_PETSc) @@ -184,7 +184,7 @@ end subroutine grid_thermal_spectral_init !-------------------------------------------------------------------------------------------------- function grid_thermal_spectral_solution(Delta_t) result(solution) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t !< increment in time for current solution integer :: i, j, k, ce type(tSolutionState) :: solution @@ -251,7 +251,7 @@ subroutine grid_thermal_spectral_forward(cutBack) integer :: i, j, k, ce DM :: dm_local - real(pReal), dimension(:,:,:), pointer :: T_PETSc + real(pREAL), dimension(:,:,:), pointer :: T_PETSc PetscErrorCode :: err_PETSc @@ -290,7 +290,7 @@ subroutine grid_thermal_spectral_restartWrite PetscErrorCode :: err_PETSc DM :: dm_local integer(HID_T) :: fileHandle, groupHandle - real(pReal), dimension(:,:,:), pointer :: T + real(pREAL), dimension(:,:,:), pointer :: T call SNESGetDM(SNES_thermal,dm_local,err_PETSc); CHKERRQ(err_PETSc) @@ -321,15 +321,15 @@ subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc) DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & residual_subdomain - real(pReal), dimension(cells(1),cells(2),cells3), intent(in) :: & + real(pREAL), dimension(cells(1),cells(2),cells3), intent(in) :: & x_scal - real(pReal), dimension(cells(1),cells(2),cells3), intent(out) :: & + real(pREAL), dimension(cells(1),cells(2),cells3), intent(out) :: & r !< residual PetscObject :: dummy PetscErrorCode, intent(out) :: err_PETSc integer :: i, j, k, ce - real(pReal), dimension(3,cells(1),cells(2),cells3) :: vectorField + real(pREAL), dimension(3,cells(1),cells(2),cells3) :: vectorField T = x_scal @@ -364,8 +364,8 @@ subroutine updateReference() integer(MPI_INTEGER_KIND) :: err_MPI - K_ref = 0.0_pReal - mu_ref = 0.0_pReal + K_ref = 0.0_pREAL + mu_ref = 0.0_pREAL do ce = 1, product(cells(1:2))*cells3 K_ref = K_ref + homogenization_K_T(ce) mu_ref = mu_ref + homogenization_mu_T(ce) diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index 0d6b71963..5f82b5a8f 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -32,8 +32,8 @@ module spectral_utilities !-------------------------------------------------------------------------------------------------- ! grid related information - real(pReal), protected, public :: wgt !< weighting factor 1/Nelems - real(pReal), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence + real(pREAL), protected, public :: wgt !< weighting factor 1/Nelems + real(pREAL), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence integer :: & cells1Red, & !< cells(1)/2+1 cells2, & !< (local) cells in 2nd direction @@ -48,10 +48,10 @@ module spectral_utilities complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:,:), pointer :: tensorField_fourier !< tensor field in Fourier space complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field in Fourier space complex(C_DOUBLE_COMPLEX), dimension(:,:,:), pointer :: scalarField_fourier !< scalar field in Fourier space - complex(pReal), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method - complex(pReal), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives - complex(pReal), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives - real(pReal), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness + complex(pREAL), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method + complex(pREAL), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives + complex(pREAL), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives + real(pREAL), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness !-------------------------------------------------------------------------------------------------- @@ -76,16 +76,16 @@ module spectral_utilities end type tSolutionState type, public :: tBoundaryCondition !< set of parameters defining a boundary condition - real(pReal), dimension(3,3) :: values = 0.0_pReal + real(pREAL), dimension(3,3) :: values = 0.0_pREAL logical, dimension(3,3) :: mask = .true. character(len=:), allocatable :: myType end type tBoundaryCondition type, public :: tSolutionParams - real(pReal), dimension(3,3) :: stress_BC + real(pREAL), dimension(3,3) :: stress_BC logical, dimension(3,3) :: stress_mask type(tRotation) :: rotation_BC - real(pReal) :: Delta_t + real(pREAL) :: Delta_t end type tSolutionParams type :: tNumerics @@ -172,7 +172,7 @@ subroutine spectral_utilities_init() CHKERRQ(err_PETSc) cells1Red = cells(1)/2 + 1 - wgt = real(product(cells),pReal)**(-1) + wgt = real(product(cells),pREAL)**(-1) num%memory_efficient = num_grid%get_asInt('memory_efficient', defaultVal=1) > 0 ! ToDo: should be logical in YAML file num%divergence_correction = num_grid%get_asInt('divergence_correction', defaultVal=2) @@ -201,9 +201,9 @@ subroutine spectral_utilities_init() end do elseif (num%divergence_correction == 2) then do j = 1, 3 - if ( j /= int(minloc(geomSize/real(cells,pReal),1)) & - .and. j /= int(maxloc(geomSize/real(cells,pReal),1))) & - scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pReal) + if ( j /= int(minloc(geomSize/real(cells,pREAL),1)) & + .and. j /= int(maxloc(geomSize/real(cells,pREAL),1))) & + scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pREAL) end do else scaledGeomSize = geomSize @@ -225,8 +225,8 @@ subroutine spectral_utilities_init() !-------------------------------------------------------------------------------------------------- ! general initialization of FFTW (see manual on fftw.org for more details) - if (pReal /= C_DOUBLE .or. kind(1) /= C_INT) error stop 'C and Fortran datatypes do not match' - call fftw_set_timelimit(num_grid%get_asReal('fftw_timelimit',defaultVal=300.0_pReal)) + if (pREAL /= C_DOUBLE .or. kind(1) /= C_INT) error stop 'C and Fortran datatypes do not match' + call fftw_set_timelimit(num_grid%get_asReal('fftw_timelimit',defaultVal=300.0_pREAL)) print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT) @@ -268,8 +268,8 @@ subroutine spectral_utilities_init() !-------------------------------------------------------------------------------------------------- ! allocation - allocate (xi1st (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for first derivatives, only half the size for first dimension - allocate (xi2nd (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for second derivatives, only half the size for first dimension + allocate (xi1st (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) ! frequencies for first derivatives, only half the size for first dimension + allocate (xi2nd (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) ! frequencies for second derivatives, only half the size for first dimension !-------------------------------------------------------------------------------------------------- ! tensor MPI fftw plans @@ -321,16 +321,16 @@ subroutine spectral_utilities_init() xi2nd(1:3,i,k,j-cells2Offset) = utilities_getFreqDerivative(k_s) where(mod(cells,2)==0 .and. [i,j,k] == cells/2+1 .and. & spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) ! for even grids, set the Nyquist Freq component to 0.0 - xi1st(1:3,i,k,j-cells2Offset) = cmplx(0.0_pReal,0.0_pReal,pReal) + xi1st(1:3,i,k,j-cells2Offset) = cmplx(0.0_pREAL,0.0_pREAL,pREAL) elsewhere xi1st(1:3,i,k,j-cells2Offset) = xi2nd(1:3,i,k,j-cells2Offset) endwhere end do; end do; end do if (num%memory_efficient) then ! allocate just single fourth order tensor - allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pReal,0.0_pReal,pReal)) + allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) else ! precalculation of gamma_hat field - allocate (gamma_hat(3,3,3,3,cells1Red,cells(3),cells2), source = cmplx(0.0_pReal,0.0_pReal,pReal)) + allocate (gamma_hat(3,3,3,3,cells1Red,cells(3),cells2), source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) end if call selfTest() @@ -346,10 +346,10 @@ end subroutine spectral_utilities_init !--------------------------------------------------------------------------------------------------- subroutine utilities_updateGamma(C) - real(pReal), intent(in), dimension(3,3,3,3) :: C !< input stiffness to store as reference stiffness + real(pREAL), intent(in), dimension(3,3,3,3) :: C !< input stiffness to store as reference stiffness - complex(pReal), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx - real(pReal), dimension(6,6) :: A, A_inv + complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx + real(pREAL), dimension(6,6) :: A, A_inv integer :: & i, j, k, & l, m, n, o @@ -359,7 +359,7 @@ subroutine utilities_updateGamma(C) C_ref = C/wgt if (.not. num%memory_efficient) then - gamma_hat = cmplx(0.0_pReal,0.0_pReal,pReal) ! for the singular point and any non invertible A + gamma_hat = cmplx(0.0_pREAL,0.0_pREAL,pREAL) ! for the singular point and any non invertible A !$OMP PARALLEL DO PRIVATE(l,m,n,o,temp33_cmplx,xiDyad_cmplx,A,A_inv,err) do j = cells2Offset+1, cells2Offset+cells2; do k = 1, cells(3); do i = 1, cells1Red if (any([i,j,k] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1 @@ -368,19 +368,19 @@ subroutine utilities_updateGamma(C) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset) end do do concurrent(l = 1:3, m = 1:3) - temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) + temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx) end do #else forall(l = 1:3, m = 1:3) & xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset) forall(l = 1:3, m = 1:3) & - temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) + temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx) #endif A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im - if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then + if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pREAL) then call math_invert(A_inv, err, A) - temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal) + temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pREAL) #ifndef __INTEL_COMPILER do concurrent(l=1:3, m=1:3, n=1:3, o=1:3) gamma_hat(l,m,n,o,i,k,j-cells2Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m) @@ -404,12 +404,12 @@ end subroutine utilities_updateGamma !-------------------------------------------------------------------------------------------------- function utilities_GammaConvolution(field, fieldAim) result(gammaField) - real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: field - real(pReal), intent(in), dimension(3,3) :: fieldAim !< desired average value of the field after convolution - real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: gammaField + real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: field + real(pREAL), intent(in), dimension(3,3) :: fieldAim !< desired average value of the field after convolution + real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: gammaField - complex(pReal), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx - real(pReal), dimension(6,6) :: A, A_inv + complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx + real(pREAL), dimension(6,6) :: A, A_inv integer :: & i, j, k, & l, m, n, o @@ -419,7 +419,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField) print'(/,1x,a)', '... doing gamma convolution ...............................................' flush(IO_STDOUT) - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) @@ -432,19 +432,19 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j) end do do concurrent(l = 1:3, m = 1:3) - temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) + temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx) end do #else forall(l = 1:3, m = 1:3) & xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j) forall(l = 1:3, m = 1:3) & - temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) + temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx) #endif A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im - if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then + if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pREAL) then call math_invert(A_inv, err, A) - temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal) + temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pREAL) #ifndef __INTEL_COMPILER do concurrent(l=1:3, m=1:3, n=1:3, o=1:3) gamma_hat(l,m,n,o,1,1,1) = temp33_cmplx(l,n)*xiDyad_cmplx(o,m) @@ -460,7 +460,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField) #endif tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx else - tensorField_fourier(1:3,1:3,i,k,j) = cmplx(0.0_pReal,0.0_pReal,pReal) + tensorField_fourier(1:3,1:3,i,k,j) = cmplx(0.0_pREAL,0.0_pREAL,pREAL) end if end if end do; end do; end do @@ -481,7 +481,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField) !$OMP END PARALLEL DO end if memoryEfficient - if (cells3Offset == 0) tensorField_fourier(1:3,1:3,1,1,1) = cmplx(fieldAim,0.0_pReal,pReal) + if (cells3Offset == 0) tensorField_fourier(1:3,1:3,1,1,1) = cmplx(fieldAim,0.0_pREAL,pREAL) call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) gammaField = tensorField_real(1:3,1:3,1:cells(1),1:cells(2),1:cells3) @@ -494,24 +494,24 @@ end function utilities_GammaConvolution !-------------------------------------------------------------------------------------------------- function utilities_GreenConvolution(field, D_ref, mu_ref, Delta_t) result(greenField) - real(pReal), intent(in), dimension(cells(1),cells(2),cells3) :: field - real(pReal), dimension(3,3), intent(in) :: D_ref - real(pReal), intent(in) :: mu_ref, Delta_t - real(pReal), dimension(cells(1),cells(2),cells3) :: greenField + real(pREAL), intent(in), dimension(cells(1),cells(2),cells3) :: field + real(pREAL), dimension(3,3), intent(in) :: D_ref + real(pREAL), intent(in) :: mu_ref, Delta_t + real(pREAL), dimension(cells(1),cells(2),cells3) :: greenField - complex(pReal) :: GreenOp_hat + complex(pREAL) :: GreenOp_hat integer :: i, j, k - scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) !$OMP PARALLEL DO PRIVATE(GreenOp_hat) do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red - GreenOp_hat = cmplx(wgt,0.0_pReal,pReal) & - / (cmplx(mu_ref,0.0_pReal,pReal) + cmplx(Delta_t,0.0_pReal,pReal) & - * sum(conjg(xi1st(1:3,i,k,j))* matmul(cmplx(D_ref,0.0_pReal,pReal),xi1st(1:3,i,k,j)))) + GreenOp_hat = cmplx(wgt,0.0_pREAL,pREAL) & + / (cmplx(mu_ref,0.0_pREAL,pREAL) + cmplx(Delta_t,0.0_pREAL,pREAL) & + * sum(conjg(xi1st(1:3,i,k,j))* matmul(cmplx(D_ref,0.0_pREAL,pREAL),xi1st(1:3,i,k,j)))) scalarField_fourier(i,k,j) = scalarField_fourier(i,k,j)*GreenOp_hat end do; end do; end do !$OMP END PARALLEL DO @@ -525,28 +525,28 @@ end function utilities_GreenConvolution !-------------------------------------------------------------------------------------------------- !> @brief Calculate root mean square of divergence. !-------------------------------------------------------------------------------------------------- -real(pReal) function utilities_divergenceRMS(tensorField) +real(pREAL) function utilities_divergenceRMS(tensorField) - real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField + real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField integer :: i, j, k integer(MPI_INTEGER_KIND) :: err_MPI - complex(pReal), dimension(3) :: rescaledGeom + complex(pREAL), dimension(3) :: rescaledGeom - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) - rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal) + rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pREAL,pREAL) !-------------------------------------------------------------------------------------------------- ! calculating RMS divergence criterion in Fourier space - utilities_divergenceRMS = 0.0_pReal + utilities_divergenceRMS = 0.0_pREAL do j = 1, cells2; do k = 1, cells(3) do i = 2, cells1Red -1 ! Has somewhere a conj. complex counterpart. Therefore count it twice. utilities_divergenceRMS = utilities_divergenceRMS & - + 2.0_pReal*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,k,j), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again + + 2.0_pREAL*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,k,j), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2) & ! --> sum squared L_2 norm of vector +sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,k,j),& conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2)) @@ -564,7 +564,7 @@ real(pReal) function utilities_divergenceRMS(tensorField) call MPI_Allreduce(MPI_IN_PLACE,utilities_divergenceRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' utilities_divergenceRMS = sqrt(utilities_divergenceRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space - if (cells(1) == 1) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pReal ! counted twice in case of cells(1) == 1 + if (cells(1) == 1) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pREAL ! counted twice in case of cells(1) == 1 end function utilities_divergenceRMS @@ -572,25 +572,25 @@ end function utilities_divergenceRMS !-------------------------------------------------------------------------------------------------- !> @brief Calculate root mean square of curl. !-------------------------------------------------------------------------------------------------- -real(pReal) function utilities_curlRMS(tensorField) +real(pREAL) function utilities_curlRMS(tensorField) - real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField + real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField integer :: i, j, k, l integer(MPI_INTEGER_KIND) :: err_MPI - complex(pReal), dimension(3,3) :: curl_fourier - complex(pReal), dimension(3) :: rescaledGeom + complex(pREAL), dimension(3,3) :: curl_fourier + complex(pREAL), dimension(3) :: rescaledGeom - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) - rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal) + rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pREAL,pREAL) !-------------------------------------------------------------------------------------------------- ! calculating max curl criterion in Fourier space - utilities_curlRMS = 0.0_pReal + utilities_curlRMS = 0.0_pREAL do j = 1, cells2; do k = 1, cells(3); do i = 2, cells1Red - 1 @@ -603,7 +603,7 @@ real(pReal) function utilities_curlRMS(tensorField) -tensorField_fourier(l,1,i,k,j)*xi1st(2,i,k,j)*rescaledGeom(2)) end do utilities_curlRMS = utilities_curlRMS & - +2.0_pReal*sum(curl_fourier%re**2+curl_fourier%im**2) ! Has somewhere a conj. complex counterpart. Therefore count it twice. + +2.0_pREAL*sum(curl_fourier%re**2+curl_fourier%im**2) ! Has somewhere a conj. complex counterpart. Therefore count it twice. end do do l = 1, 3 curl_fourier = (+tensorField_fourier(l,3,1,k,j)*xi1st(2,1,k,j)*rescaledGeom(2) & @@ -630,7 +630,7 @@ real(pReal) function utilities_curlRMS(tensorField) call MPI_Allreduce(MPI_IN_PLACE,utilities_curlRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' utilities_curlRMS = sqrt(utilities_curlRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space - if (cells(1) == 1) utilities_curlRMS = utilities_curlRMS * 0.5_pReal ! counted twice in case of cells(1) == 1 + if (cells(1) == 1) utilities_curlRMS = utilities_curlRMS * 0.5_pREAL ! counted twice in case of cells(1) == 1 end function utilities_curlRMS @@ -640,17 +640,17 @@ end function utilities_curlRMS !-------------------------------------------------------------------------------------------------- function utilities_maskedCompliance(rot_BC,mask_stress,C) - real(pReal), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance - real(pReal), intent(in), dimension(3,3,3,3) :: C !< current average stiffness + real(pREAL), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance + real(pREAL), intent(in), dimension(3,3,3,3) :: C !< current average stiffness type(tRotation), intent(in) :: rot_BC !< rotation of load frame logical, intent(in), dimension(3,3) :: mask_stress !< mask of stress BC integer :: i, j logical, dimension(9) :: mask_stressVector logical, dimension(9,9) :: mask - real(pReal), dimension(9,9) :: temp99_real + real(pREAL), dimension(9,9) :: temp99_real integer :: size_reduced = 0 - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & s_reduced, & !< reduced compliance matrix (depending on number of stress BC) c_reduced, & !< reduced stiffness (depending on number of stress BC) sTimesC !< temp variable to check inversion @@ -674,7 +674,7 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C) !-------------------------------------------------------------------------------------------------- ! check if inversion was successful sTimesC = matmul(c_reduced,s_reduced) - errmatinv = errmatinv .or. any(dNeq(sTimesC,math_eye(size_reduced),1.0e-12_pReal)) + errmatinv = errmatinv .or. any(dNeq(sTimesC,math_eye(size_reduced),1.0e-12_pREAL)) if (errmatinv) then write(formatString, '(i2)') size_reduced formatString = '(/,1x,a,/,'//trim(formatString)//'('//trim(formatString)//'(2x,es9.2,1x)/))' @@ -682,9 +682,9 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C) print trim(formatString), 'S (load) ', transpose(s_reduced) if (errmatinv) error stop 'matrix inversion error' end if - temp99_real = reshape(unpack(reshape(s_reduced,[size_reduced**2]),reshape(mask,[81]),0.0_pReal),[9,9]) + temp99_real = reshape(unpack(reshape(s_reduced,[size_reduced**2]),reshape(mask,[81]),0.0_pREAL),[9,9]) else - temp99_real = 0.0_pReal + temp99_real = 0.0_pREAL end if utilities_maskedCompliance = math_99to3333(temp99_Real) @@ -697,13 +697,13 @@ end function utilities_maskedCompliance !-------------------------------------------------------------------------------------------------- function utilities_scalarGradient(field) result(grad) - real(pReal), intent(in), dimension( cells(1),cells(2),cells3) :: field - real(pReal), dimension(3,cells(1),cells(2),cells3) :: grad + real(pREAL), intent(in), dimension( cells(1),cells(2),cells3) :: field + real(pREAL), dimension(3,cells(1),cells(2),cells3) :: grad integer :: i, j, k - scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red @@ -720,11 +720,11 @@ end function utilities_scalarGradient !-------------------------------------------------------------------------------------------------- function utilities_vectorDivergence(field) result(div) - real(pReal), intent(in), dimension(3,cells(1),cells(2),cells3) :: field - real(pReal), dimension( cells(1),cells(2),cells3) :: div + real(pREAL), intent(in), dimension(3,cells(1),cells(2),cells3) :: field + real(pREAL), dimension( cells(1),cells(2),cells3) :: div - vectorField_real(1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + vectorField_real(1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL vectorField_real(1:3,1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) scalarField_fourier(1:cells1Red,1:cells(3),1:cells2) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(3),1:cells2) & @@ -741,19 +741,19 @@ end function utilities_vectorDivergence subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& F,Delta_t,rotation_BC) - real(pReal), intent(out), dimension(3,3,3,3) :: C_volAvg, C_minmaxAvg !< average stiffness - real(pReal), intent(out), dimension(3,3) :: P_av !< average PK stress - real(pReal), intent(out), dimension(3,3,cells(1),cells(2),cells3) :: P !< PK stress - real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: F !< deformation gradient target - real(pReal), intent(in) :: Delta_t !< loading time + real(pREAL), intent(out), dimension(3,3,3,3) :: C_volAvg, C_minmaxAvg !< average stiffness + real(pREAL), intent(out), dimension(3,3) :: P_av !< average PK stress + real(pREAL), intent(out), dimension(3,3,cells(1),cells(2),cells3) :: P !< PK stress + real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: F !< deformation gradient target + real(pREAL), intent(in) :: Delta_t !< loading time type(tRotation), intent(in), optional :: rotation_BC !< rotation of load frame integer :: i integer(MPI_INTEGER_KIND) :: err_MPI - real(pReal), dimension(3,3,3,3) :: dPdF_max, dPdF_min - real(pReal) :: dPdF_norm_max, dPdF_norm_min - real(pReal), dimension(2) :: valueAndRank !< pair of min/max norm of dPdF to synchronize min/max of dPdF + real(pREAL), dimension(3,3,3,3) :: dPdF_max, dPdF_min + real(pREAL) :: dPdF_norm_max, dPdF_norm_min + real(pREAL), dimension(2) :: valueAndRank !< pair of min/max norm of dPdF to synchronize min/max of dPdF print'(/,1x,a)', '... evaluating constitutive response ......................................' flush(IO_STDOUT) @@ -771,19 +771,19 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& call MPI_Allreduce(MPI_IN_PLACE,P_av,9_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (present(rotation_BC)) then - if (any(dNeq(rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & + if (any(dNeq(rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) & print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & - 'Piola--Kirchhoff stress (lab) / MPa =', transpose(P_av)*1.e-6_pReal + 'Piola--Kirchhoff stress (lab) / MPa =', transpose(P_av)*1.e-6_pREAL P_av = rotation_BC%rotate(P_av) end if print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & - 'Piola--Kirchhoff stress / MPa =', transpose(P_av)*1.e-6_pReal + 'Piola--Kirchhoff stress / MPa =', transpose(P_av)*1.e-6_pREAL flush(IO_STDOUT) - dPdF_max = 0.0_pReal - dPdF_norm_max = 0.0_pReal - dPdF_min = huge(1.0_pReal) - dPdF_norm_min = huge(1.0_pReal) + dPdF_max = 0.0_pREAL + dPdF_norm_max = 0.0_pREAL + dPdF_min = huge(1.0_pREAL) + dPdF_norm_min = huge(1.0_pREAL) do i = 1, product(cells(1:2))*cells3 if (dPdF_norm_max < sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)) then dPdF_max = homogenization_dPdF(1:3,1:3,1:3,1:3,i) @@ -795,19 +795,19 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& end if end do - valueAndRank = [dPdF_norm_max,real(worldrank,pReal)] + valueAndRank = [dPdF_norm_max,real(worldrank,pREAL)] call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call MPI_Bcast(dPdF_max,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' - valueAndRank = [dPdF_norm_min,real(worldrank,pReal)] + valueAndRank = [dPdF_norm_min,real(worldrank,pREAL)] call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call MPI_Bcast(dPdF_min,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' - C_minmaxAvg = 0.5_pReal*(dPdF_max + dPdF_min) + C_minmaxAvg = 0.5_pREAL*(dPdF_max + dPdF_min) C_volAvg = sum(homogenization_dPdF,dim=5) call MPI_Allreduce(MPI_IN_PLACE,C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) @@ -823,16 +823,16 @@ end subroutine utilities_constitutiveResponse !-------------------------------------------------------------------------------------------------- pure function utilities_calculateRate(heterogeneous,field0,field,dt,avRate) - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & avRate !< homogeneous addon - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & dt !< Delta_t between field0 and field logical, intent(in) :: & heterogeneous !< calculate field of rates - real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & + real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & field0, & !< data of previous step field !< data of current step - real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: & + real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: & utilities_calculateRate @@ -849,17 +849,17 @@ end function utilities_calculateRate !-------------------------------------------------------------------------------------------------- function utilities_forwardField(Delta_t,field_lastInc,rate,aim) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & Delta_t !< Delta_t of current step - real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & + real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & field_lastInc, & !< initial field rate !< rate by which to forward - real(pReal), intent(in), optional, dimension(3,3) :: & + real(pREAL), intent(in), optional, dimension(3,3) :: & aim !< average field value aim - real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: & + real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: & utilities_forwardField - real(pReal), dimension(3,3) :: fieldDiff !< - aim + real(pREAL), dimension(3,3) :: fieldDiff !< - aim integer(MPI_INTEGER_KIND) :: err_MPI @@ -885,42 +885,42 @@ pure function utilities_getFreqDerivative(k_s) integer, intent(in), dimension(3) :: k_s !< indices of frequency - complex(pReal), dimension(3) :: utilities_getFreqDerivative + complex(pREAL), dimension(3) :: utilities_getFreqDerivative select case (spectral_derivative_ID) case (DERIVATIVE_CONTINUOUS_ID) - utilities_getFreqDerivative = cmplx(0.0_pReal, TAU*real(k_s,pReal)/geomSize,pReal) + utilities_getFreqDerivative = cmplx(0.0_pREAL, TAU*real(k_s,pREAL)/geomSize,pREAL) case (DERIVATIVE_CENTRAL_DIFF_ID) - utilities_getFreqDerivative = cmplx(0.0_pReal, sin(TAU*real(k_s,pReal)/real(cells,pReal)), pReal)/ & - cmplx(2.0_pReal*geomSize/real(cells,pReal), 0.0_pReal, pReal) + utilities_getFreqDerivative = cmplx(0.0_pREAL, sin(TAU*real(k_s,pREAL)/real(cells,pREAL)), pREAL)/ & + cmplx(2.0_pREAL*geomSize/real(cells,pREAL), 0.0_pREAL, pREAL) case (DERIVATIVE_FWBW_DIFF_ID) utilities_getFreqDerivative(1) = & - cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) - 1.0_pReal, & - sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & - cmplx(4.0_pReal*geomSize(1)/real(cells(1),pReal), 0.0_pReal, pReal) + cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) - 1.0_pREAL, & + sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ & + cmplx(4.0_pREAL*geomSize(1)/real(cells(1),pREAL), 0.0_pREAL, pREAL) utilities_getFreqDerivative(2) = & - cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) - 1.0_pReal, & - sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & - cmplx(4.0_pReal*geomSize(2)/real(cells(2),pReal), 0.0_pReal, pReal) + cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) - 1.0_pREAL, & + sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ & + cmplx(4.0_pREAL*geomSize(2)/real(cells(2),pREAL), 0.0_pREAL, pREAL) utilities_getFreqDerivative(3) = & - cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) + 1.0_pReal, & - sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & - cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) - 1.0_pReal, & - sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & - cmplx(4.0_pReal*geomSize(3)/real(cells(3),pReal), 0.0_pReal, pReal) + cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) + 1.0_pREAL, & + sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* & + cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) - 1.0_pREAL, & + sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ & + cmplx(4.0_pREAL*geomSize(3)/real(cells(3),pREAL), 0.0_pREAL, pREAL) end select end function utilities_getFreqDerivative @@ -932,11 +932,11 @@ end function utilities_getFreqDerivative !-------------------------------------------------------------------------------------------------- subroutine utilities_updateCoords(F) - real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: F + real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: F - real(pReal), dimension(3, cells(1),cells(2),cells3) :: x_p !< Point/cell center coordinates - real(pReal), dimension(3, cells(1),cells(2),0:cells3+1) :: u_tilde_p_padded !< Fluctuation of cell center displacement (padded along z for MPI) - real(pReal), dimension(3, cells(1)+1,cells(2)+1,cells3+1) :: x_n !< Node coordinates + real(pREAL), dimension(3, cells(1),cells(2),cells3) :: x_p !< Point/cell center coordinates + real(pREAL), dimension(3, cells(1),cells(2),0:cells3+1) :: u_tilde_p_padded !< Fluctuation of cell center displacement (padded along z for MPI) + real(pREAL), dimension(3, cells(1)+1,cells(2)+1,cells3+1) :: x_n !< Node coordinates integer :: & i,j,k,n, & c @@ -950,8 +950,8 @@ subroutine utilities_updateCoords(F) integer, dimension(4) :: request integer, dimension(MPI_STATUS_SIZE,4) :: status #endif - real(pReal), dimension(3) :: step - real(pReal), dimension(3,3) :: Favg + real(pREAL), dimension(3) :: step + real(pREAL), dimension(3,3) :: Favg integer, dimension(3) :: me integer, dimension(3,8) :: & neighbor = reshape([ & @@ -965,10 +965,10 @@ subroutine utilities_updateCoords(F) 0, 1, 1 ], [3,8]) - step = geomSize/real(cells, pReal) + step = geomSize/real(cells, pREAL) tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = F - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) !-------------------------------------------------------------------------------------------------- @@ -985,7 +985,7 @@ subroutine utilities_updateCoords(F) vectorField_fourier(1:3,i,k,j) = matmul(tensorField_fourier(1:3,1:3,i,k,j),xi2nd(1:3,i,k,j)) & / sum(conjg(-xi2nd(1:3,i,k,j))*xi2nd(1:3,i,k,j)) else - vectorField_fourier(1:3,i,k,j) = cmplx(0.0,0.0,pReal) + vectorField_fourier(1:3,i,k,j) = cmplx(0.0,0.0,pREAL) end if end do; end do; end do !$OMP END PARALLEL DO @@ -1021,13 +1021,13 @@ subroutine utilities_updateCoords(F) !-------------------------------------------------------------------------------------------------- ! calculate nodal positions - x_n = 0.0_pReal + x_n = 0.0_pREAL do j = 0,cells(2); do k = 0,cells3; do i = 0,cells(1) - x_n(1:3,i+1,j+1,k+1) = matmul(Favg,step*(real([i,j,k+cells3Offset],pReal))) + x_n(1:3,i+1,j+1,k+1) = matmul(Favg,step*(real([i,j,k+cells3Offset],pREAL))) averageFluct: do n = 1,8 me = [i+neighbor(1,n),j+neighbor(2,n),k+neighbor(3,n)] x_n(1:3,i+1,j+1,k+1) = x_n(1:3,i+1,j+1,k+1) & - + u_tilde_p_padded(1:3,modulo(me(1)-1,cells(1))+1,modulo(me(2)-1,cells(2))+1,me(3))*0.125_pReal + + u_tilde_p_padded(1:3,modulo(me(1)-1,cells(1))+1,modulo(me(2)-1,cells(2))+1,me(3))*0.125_pREAL end do averageFluct end do; end do; end do @@ -1035,7 +1035,7 @@ subroutine utilities_updateCoords(F) ! calculate cell center/point positions do k = 1,cells3; do j = 1,cells(2); do i = 1,cells(1) x_p(1:3,i,j,k) = u_tilde_p_padded(1:3,i,j,k) & - + matmul(Favg,step*(real([i,j,k+cells3Offset],pReal)-0.5_pReal)) + + matmul(Favg,step*(real([i,j,k+cells3Offset],pREAL)-0.5_pREAL)) end do; end do; end do call discretization_setNodeCoords(reshape(x_n,[3,(cells(1)+1)*(cells(2)+1)*(cells3+1)])) @@ -1049,62 +1049,62 @@ end subroutine utilities_updateCoords !-------------------------------------------------------------------------------------------------- subroutine selfTest() - real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_ - real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_ - real(pReal), allocatable, dimension(:,:,:) :: scalarField_real_ - real(pReal), dimension(3,3) :: tensorSum - real(pReal), dimension(3) :: vectorSum - real(pReal) :: scalarSum - real(pReal), dimension(3,3) :: r + real(pREAL), allocatable, dimension(:,:,:,:,:) :: tensorField_real_ + real(pREAL), allocatable, dimension(:,:,:,:) :: vectorField_real_ + real(pREAL), allocatable, dimension(:,:,:) :: scalarField_real_ + real(pREAL), dimension(3,3) :: tensorSum + real(pREAL), dimension(3) :: vectorSum + real(pREAL) :: scalarSum + real(pREAL), dimension(3,3) :: r integer(MPI_INTEGER_KIND) :: err_MPI call random_number(tensorField_real) - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL tensorField_real_ = tensorField_real call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call MPI_Allreduce(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3),tensorSum,9_MPI_INTEGER_KIND, & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (worldrank==0) then - if (any(dNeq(tensorSum/tensorField_fourier(:,:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & + if (any(dNeq(tensorSum/tensorField_fourier(:,:,1,1,1)%re,1.0_pREAL,1.0e-12_pREAL))) & error stop 'mismatch avg tensorField FFT <-> real' end if call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pReal) & + tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL + if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pREAL) & error stop 'mismatch tensorField FFT/invFFT <-> real' call random_number(vectorField_real) - vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal + vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL vectorField_real_ = vectorField_real call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) call MPI_Allreduce(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2),vectorSum,3_MPI_INTEGER_KIND, & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (worldrank==0) then - if (any(dNeq(vectorSum/vectorField_fourier(:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & + if (any(dNeq(vectorSum/vectorField_fourier(:,1,1,1)%re,1.0_pREAL,1.0e-12_pREAL))) & error stop 'mismatch avg vectorField FFT <-> real' end if call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) - vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pReal) & + vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL + if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pREAL) & error stop 'mismatch vectorField FFT/invFFT <-> real' call random_number(scalarField_real) - scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal + scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL scalarField_real_ = scalarField_real call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call MPI_Allreduce(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1),scalarSum,1_MPI_INTEGER_KIND, & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (worldrank==0) then - if (dNeq(scalarSum/scalarField_fourier(1,1,1)%re,1.0_pReal,1.0e-12_pReal)) & + if (dNeq(scalarSum/scalarField_fourier(1,1,1)%re,1.0_pREAL,1.0e-12_pREAL)) & error stop 'mismatch avg scalarField FFT <-> real' end if call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real) - scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pReal) & + scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL + if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pREAL) & error stop 'mismatch scalarField FFT/invFFT <-> real' call random_number(r) @@ -1112,54 +1112,54 @@ subroutine selfTest() if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' scalarField_real_ = r(1,1) - if (maxval(abs(utilities_scalarGradient(scalarField_real_)))>5.0e-9_pReal) error stop 'non-zero grad(const)' + if (maxval(abs(utilities_scalarGradient(scalarField_real_)))>5.0e-9_pREAL) error stop 'non-zero grad(const)' vectorField_real_ = spread(spread(spread(r(1,:),2,cells(1)),3,cells(2)),4,cells3) - if (maxval(abs(utilities_vectorDivergence(vectorField_real_)))>5.0e-9_pReal) error stop 'non-zero div(const)' + if (maxval(abs(utilities_vectorDivergence(vectorField_real_)))>5.0e-9_pREAL) error stop 'non-zero div(const)' tensorField_real_ = spread(spread(spread(r,3,cells(1)),4,cells(2)),5,cells3) - if (utilities_divergenceRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS div(const)' - if (utilities_curlRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS curl(const)' + if (utilities_divergenceRMS(tensorField_real_)>5.0e-14_pREAL) error stop 'non-zero RMS div(const)' + if (utilities_curlRMS(tensorField_real_)>5.0e-14_pREAL) error stop 'non-zero RMS curl(const)' if (cells(1) > 2 .and. spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) then scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) scalarField_real_ = -spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) - if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'grad cosine' + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'grad cosine' scalarField_real_ = spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) - if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'grad sine' + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'grad sine' - vectorField_real_(2:3,:,:,:) = 0.0_pReal + vectorField_real_(2:3,:,:,:) = 0.0_pREAL vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) vectorField_real_(1,:,:,:) =-spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) - if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'div cosine' - vectorField_real_(2:3,:,:,:) = 0.0_pReal + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'div cosine' + vectorField_real_(2:3,:,:,:) = 0.0_pREAL vectorField_real_(1,:,:,:) = spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) - if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'div sine' + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'div sine' end if contains function planeCosine(n) integer, intent(in) :: n - real(pReal), dimension(n) :: planeCosine + real(pREAL), dimension(n) :: planeCosine - planeCosine = cos(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) + planeCosine = cos(real(math_range(n),pREAL)/real(n,pREAL)*TAU-TAU/real(n*2,pREAL)) end function planeCosine function planeSine(n) integer, intent(in) :: n - real(pReal), dimension(n) :: planeSine + real(pREAL), dimension(n) :: planeSine - planeSine = sin(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) + planeSine = sin(real(math_range(n),pREAL)/real(n,pREAL)*TAU-TAU/real(n*2,pREAL)) end function planeSine diff --git a/src/homogenization.f90 b/src/homogenization.f90 index d4c9e0941..f322c2c07 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -25,7 +25,7 @@ module homogenization integer :: & sizeState = 0 !< size of state ! http://stackoverflow.com/questions/3948210 - real(pReal), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer + real(pREAL), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer state0, & state end type @@ -51,12 +51,12 @@ module homogenization !-------------------------------------------------------------------------------------------------- ! General variables for the homogenization at a material point - real(pReal), dimension(:,:,:), allocatable, public :: & + real(pREAL), dimension(:,:,:), allocatable, public :: & homogenization_F0, & !< def grad of IP at start of FE increment homogenization_F !< def grad of IP to be reached at end of FE increment - real(pReal), dimension(:,:,:), allocatable, public :: & !, protected :: & Issue with ifort + real(pREAL), dimension(:,:,:), allocatable, public :: & !, protected :: & Issue with ifort homogenization_P !< first P--K stress of IP - real(pReal), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: & + real(pREAL), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: & homogenization_dPdF !< tangent of first P--K stress at IP @@ -81,7 +81,7 @@ module homogenization end subroutine damage_init module subroutine mechanical_partition(subF,ce) - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & subF integer, intent(in) :: & ce @@ -96,7 +96,7 @@ module homogenization end subroutine damage_partition module subroutine mechanical_homogenize(Delta_t,ce) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & ce !< cell end subroutine mechanical_homogenize @@ -117,9 +117,9 @@ module homogenization end subroutine thermal_result module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & subdt !< current time step - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & subF integer, intent(in) :: & ce !< cell @@ -132,22 +132,22 @@ module homogenization module function homogenization_mu_T(ce) result(mu) integer, intent(in) :: ce - real(pReal) :: mu + real(pREAL) :: mu end function homogenization_mu_T module function homogenization_K_T(ce) result(K) integer, intent(in) :: ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K end function homogenization_K_T module function homogenization_f_T(ce) result(f) integer, intent(in) :: ce - real(pReal) :: f + real(pREAL) :: f end function homogenization_f_T module subroutine homogenization_thermal_setField(T,dot_T, ce) integer, intent(in) :: ce - real(pReal), intent(in) :: T, dot_T + real(pREAL), intent(in) :: T, dot_T end subroutine homogenization_thermal_setField module function homogenization_damage_active() result(active) @@ -156,23 +156,23 @@ module homogenization module function homogenization_mu_phi(ce) result(mu) integer, intent(in) :: ce - real(pReal) :: mu + real(pREAL) :: mu end function homogenization_mu_phi module function homogenization_K_phi(ce) result(K) integer, intent(in) :: ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K end function homogenization_K_phi module function homogenization_f_phi(phi,ce) result(f) integer, intent(in) :: ce - real(pReal), intent(in) :: phi - real(pReal) :: f + real(pREAL), intent(in) :: phi + real(pREAL) :: f end function homogenization_f_phi module subroutine homogenization_set_phi(phi,ce) integer, intent(in) :: ce - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & phi end subroutine homogenization_set_phi @@ -235,7 +235,7 @@ end subroutine homogenization_init !-------------------------------------------------------------------------------------------------- subroutine homogenization_mechanical_response(Delta_t,cell_start,cell_end) - real(pReal), intent(in) :: Delta_t !< time increment + real(pREAL), intent(in) :: Delta_t !< time increment integer, intent(in) :: & cell_start, cell_end integer :: & @@ -293,7 +293,7 @@ end subroutine homogenization_mechanical_response !-------------------------------------------------------------------------------------------------- subroutine homogenization_thermal_response(Delta_t,cell_start,cell_end) - real(pReal), intent(in) :: Delta_t !< time increment + real(pREAL), intent(in) :: Delta_t !< time increment integer, intent(in) :: & cell_start, cell_end integer :: & @@ -321,7 +321,7 @@ end subroutine homogenization_thermal_response !-------------------------------------------------------------------------------------------------- subroutine homogenization_mechanical_response2(Delta_t,FEsolving_execIP,FEsolving_execElem) - real(pReal), intent(in) :: Delta_t !< time increment + real(pREAL), intent(in) :: Delta_t !< time increment integer, dimension(2), intent(in) :: FEsolving_execElem, FEsolving_execIP integer :: & ip, & !< integration point number diff --git a/src/homogenization_damage.f90 b/src/homogenization_damage.f90 index 7de304abc..466b8b47b 100644 --- a/src/homogenization_damage.f90 +++ b/src/homogenization_damage.f90 @@ -11,7 +11,7 @@ submodule(homogenization) damage end interface type :: tDataContainer - real(pReal), dimension(:), allocatable :: phi + real(pREAL), dimension(:), allocatable :: phi end type tDataContainer type(tDataContainer), dimension(:), allocatable :: current @@ -48,7 +48,7 @@ module subroutine damage_init() do ho = 1, configHomogenizations%length Nmembers = count(material_ID_homogenization == ho) - allocate(current(ho)%phi(Nmembers), source=1.0_pReal) + allocate(current(ho)%phi(Nmembers), source=1.0_pREAL) configHomogenization => configHomogenizations%get_dict(ho) associate(prm => param(ho)) if (configHomogenization%contains('damage')) then @@ -59,8 +59,8 @@ module subroutine damage_init() prm%output = configHomogenizationDamage%get_as1dStr('output',defaultVal=emptyStrArray) #endif damageState_h(ho)%sizeState = 1 - allocate(damageState_h(ho)%state0(1,Nmembers), source=1.0_pReal) - allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pReal) + allocate(damageState_h(ho)%state0(1,Nmembers), source=1.0_pREAL) + allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pREAL) else prm%output = emptyStrArray end if @@ -91,7 +91,7 @@ module subroutine damage_partition(ce) integer, intent(in) :: ce - real(pReal) :: phi + real(pREAL) :: phi integer :: co @@ -111,7 +111,7 @@ end subroutine damage_partition module function homogenization_mu_phi(ce) result(mu) integer, intent(in) :: ce - real(pReal) :: mu + real(pREAL) :: mu mu = phase_mu_phi(1,ce) @@ -125,7 +125,7 @@ end function homogenization_mu_phi module function homogenization_K_phi(ce) result(K) integer, intent(in) :: ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K K = phase_K_phi(1,ce) @@ -139,8 +139,8 @@ end function homogenization_K_phi module function homogenization_f_phi(phi,ce) result(f) integer, intent(in) :: ce - real(pReal), intent(in) :: phi - real(pReal) :: f + real(pREAL), intent(in) :: phi + real(pREAL) :: f f = phase_f_phi(phi, 1, ce) @@ -154,7 +154,7 @@ end function homogenization_f_phi module subroutine homogenization_set_phi(phi,ce) integer, intent(in) :: ce - real(pReal), intent(in) :: phi + real(pREAL), intent(in) :: phi integer :: & ho, & diff --git a/src/homogenization_mechanical.f90 b/src/homogenization_mechanical.f90 index 2493bbb3c..31bd42aa5 100644 --- a/src/homogenization_mechanical.f90 +++ b/src/homogenization_mechanical.f90 @@ -18,13 +18,13 @@ submodule(homogenization) mechanical module subroutine isostrain_partitionDeformation(F,avgF) - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point end subroutine isostrain_partitionDeformation module subroutine RGC_partitionDeformation(F,avgF,ce) - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point integer, intent(in) :: & ce end subroutine RGC_partitionDeformation @@ -32,12 +32,12 @@ submodule(homogenization) mechanical module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) logical, dimension(2) :: doneAndHappy - real(pReal), dimension(:,:,:), intent(in) :: & + real(pREAL), dimension(:,:,:), intent(in) :: & P,& !< partitioned stresses F !< partitioned deformation gradients - real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - real(pReal), dimension(3,3), intent(in) :: avgF !< average F - real(pReal), intent(in) :: dt !< time increment + real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + real(pREAL), dimension(3,3), intent(in) :: avgF !< average F + real(pREAL), intent(in) :: dt !< time increment integer, intent(in) :: & ce !< cell end function RGC_updateState @@ -76,10 +76,10 @@ module subroutine mechanical_init() call parseMechanical() - allocate(homogenization_dPdF(3,3,3,3,discretization_Ncells), source=0.0_pReal) + allocate(homogenization_dPdF(3,3,3,3,discretization_Ncells), source=0.0_pREAL) homogenization_F0 = spread(math_I3,3,discretization_Ncells) homogenization_F = homogenization_F0 - allocate(homogenization_P(3,3,discretization_Ncells),source=0.0_pReal) + allocate(homogenization_P(3,3,discretization_Ncells),source=0.0_pREAL) if (any(mechanical_type == MECHANICAL_PASS_ID)) call pass_init() if (any(mechanical_type == MECHANICAL_ISOSTRAIN_ID)) call isostrain_init() @@ -93,13 +93,13 @@ end subroutine mechanical_init !-------------------------------------------------------------------------------------------------- module subroutine mechanical_partition(subF,ce) - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & subF integer, intent(in) :: & ce integer :: co - real(pReal), dimension (3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) :: Fs + real(pREAL), dimension (3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) :: Fs chosenHomogenization: select case(mechanical_type(material_ID_homogenization(ce))) @@ -128,7 +128,7 @@ end subroutine mechanical_partition !-------------------------------------------------------------------------------------------------- module subroutine mechanical_homogenize(Delta_t,ce) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ce integer :: co @@ -152,18 +152,18 @@ end subroutine mechanical_homogenize !-------------------------------------------------------------------------------------------------- module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & subdt !< current time step - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & subF integer, intent(in) :: & ce logical, dimension(2) :: doneAndHappy integer :: co - real(pReal) :: dPdFs(3,3,3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) - real(pReal) :: Fs(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) - real(pReal) :: Ps(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) + real(pREAL) :: dPdFs(3,3,3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) + real(pREAL) :: Fs(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) + real(pREAL) :: Ps(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) if (mechanical_type(material_ID_homogenization(ce)) == MECHANICAL_RGC_ID) then diff --git a/src/homogenization_mechanical_RGC.f90 b/src/homogenization_mechanical_RGC.f90 index dba513ced..da8bce7c5 100644 --- a/src/homogenization_mechanical_RGC.f90 +++ b/src/homogenization_mechanical_RGC.f90 @@ -13,10 +13,10 @@ submodule(homogenization:mechanical) RGC type :: tParameters integer, dimension(:), allocatable :: & N_constituents - real(pReal) :: & + real(pREAL) :: & xi_alpha, & c_Alpha - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & D_alpha, & a_g character(len=pSTRLEN), allocatable, dimension(:) :: & @@ -24,23 +24,23 @@ submodule(homogenization:mechanical) RGC end type tParameters type :: tRGCstate - real(pReal), pointer, dimension(:,:) :: & + real(pREAL), pointer, dimension(:,:) :: & relaxationVector end type tRGCstate type :: tRGCdependentState - real(pReal), allocatable, dimension(:) :: & + real(pREAL), allocatable, dimension(:) :: & volumeDiscrepancy, & relaxationRate_avg, & relaxationRate_max - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & mismatch - real(pReal), allocatable, dimension(:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:) :: & orientation end type tRGCdependentState type :: tNumerics_RGC - real(pReal) :: & + real(pREAL) :: & atol, & !< absolute tolerance of RGC residuum rtol, & !< relative tolerance of RGC residuum absMax, & !< absolute maximum of RGC residuum @@ -108,33 +108,33 @@ module subroutine RGC_init() num_mechanical => num_homogenization%get_dict('mechanical',defaultVal=emptyDict) num_RGC => num_mechanical%get_dict('RGC',defaultVal=emptyDict) - num%atol = num_RGC%get_asReal('atol', defaultVal=1.0e+4_pReal) - num%rtol = num_RGC%get_asReal('rtol', defaultVal=1.0e-3_pReal) - num%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_pReal) - num%relMax = num_RGC%get_asReal('rmax', defaultVal=1.0e+2_pReal) - num%pPert = num_RGC%get_asReal('perturbpenalty', defaultVal=1.0e-7_pReal) - num%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_pReal) - num%viscPower = num_RGC%get_asReal('viscositypower', defaultVal=1.0e+0_pReal) - num%viscModus = num_RGC%get_asReal('viscositymodulus', defaultVal=0.0e+0_pReal) - num%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_pReal) - num%maxdRelax = num_RGC%get_asReal('maxrelaxationrate', defaultVal=1.0e+0_pReal) - num%maxVolDiscr = num_RGC%get_asReal('maxvoldiscrepancy', defaultVal=1.0e-5_pReal) - num%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_pReal) - num%volDiscrPow = num_RGC%get_asReal('dicrepancypower', defaultVal=5.0_pReal) + num%atol = num_RGC%get_asReal('atol', defaultVal=1.0e+4_pREAL) + num%rtol = num_RGC%get_asReal('rtol', defaultVal=1.0e-3_pREAL) + num%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_pREAL) + num%relMax = num_RGC%get_asReal('rmax', defaultVal=1.0e+2_pREAL) + num%pPert = num_RGC%get_asReal('perturbpenalty', defaultVal=1.0e-7_pREAL) + num%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_pREAL) + num%viscPower = num_RGC%get_asReal('viscositypower', defaultVal=1.0e+0_pREAL) + num%viscModus = num_RGC%get_asReal('viscositymodulus', defaultVal=0.0e+0_pREAL) + num%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_pREAL) + num%maxdRelax = num_RGC%get_asReal('maxrelaxationrate', defaultVal=1.0e+0_pREAL) + num%maxVolDiscr = num_RGC%get_asReal('maxvoldiscrepancy', defaultVal=1.0e-5_pREAL) + num%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_pREAL) + num%volDiscrPow = num_RGC%get_asReal('dicrepancypower', defaultVal=5.0_pREAL) - if (num%atol <= 0.0_pReal) call IO_error(301,ext_msg='absTol_RGC') - if (num%rtol <= 0.0_pReal) call IO_error(301,ext_msg='relTol_RGC') - if (num%absMax <= 0.0_pReal) call IO_error(301,ext_msg='absMax_RGC') - if (num%relMax <= 0.0_pReal) call IO_error(301,ext_msg='relMax_RGC') - if (num%pPert <= 0.0_pReal) call IO_error(301,ext_msg='pPert_RGC') - if (num%xSmoo <= 0.0_pReal) call IO_error(301,ext_msg='xSmoo_RGC') - if (num%viscPower < 0.0_pReal) call IO_error(301,ext_msg='viscPower_RGC') - if (num%viscModus < 0.0_pReal) call IO_error(301,ext_msg='viscModus_RGC') - if (num%refRelaxRate <= 0.0_pReal) call IO_error(301,ext_msg='refRelaxRate_RGC') - if (num%maxdRelax <= 0.0_pReal) call IO_error(301,ext_msg='maxdRelax_RGC') - if (num%maxVolDiscr <= 0.0_pReal) call IO_error(301,ext_msg='maxVolDiscr_RGC') - if (num%volDiscrMod < 0.0_pReal) call IO_error(301,ext_msg='volDiscrMod_RGC') - if (num%volDiscrPow <= 0.0_pReal) call IO_error(301,ext_msg='volDiscrPw_RGC') + if (num%atol <= 0.0_pREAL) call IO_error(301,ext_msg='absTol_RGC') + if (num%rtol <= 0.0_pREAL) call IO_error(301,ext_msg='relTol_RGC') + if (num%absMax <= 0.0_pREAL) call IO_error(301,ext_msg='absMax_RGC') + if (num%relMax <= 0.0_pREAL) call IO_error(301,ext_msg='relMax_RGC') + if (num%pPert <= 0.0_pREAL) call IO_error(301,ext_msg='pPert_RGC') + if (num%xSmoo <= 0.0_pREAL) call IO_error(301,ext_msg='xSmoo_RGC') + if (num%viscPower < 0.0_pREAL) call IO_error(301,ext_msg='viscPower_RGC') + if (num%viscModus < 0.0_pREAL) call IO_error(301,ext_msg='viscModus_RGC') + if (num%refRelaxRate <= 0.0_pREAL) call IO_error(301,ext_msg='refRelaxRate_RGC') + if (num%maxdRelax <= 0.0_pREAL) call IO_error(301,ext_msg='maxdRelax_RGC') + if (num%maxVolDiscr <= 0.0_pREAL) call IO_error(301,ext_msg='maxVolDiscr_RGC') + if (num%volDiscrMod < 0.0_pREAL) call IO_error(301,ext_msg='volDiscrMod_RGC') + if (num%volDiscrPow <= 0.0_pREAL) call IO_error(301,ext_msg='volDiscrPw_RGC') do ho = 1, size(mechanical_type) @@ -169,16 +169,16 @@ module subroutine RGC_init() sizeState = nIntFaceTot homogState(ho)%sizeState = sizeState - allocate(homogState(ho)%state0 (sizeState,Nmembers), source=0.0_pReal) - allocate(homogState(ho)%state (sizeState,Nmembers), source=0.0_pReal) + allocate(homogState(ho)%state0 (sizeState,Nmembers), source=0.0_pREAL) + allocate(homogState(ho)%state (sizeState,Nmembers), source=0.0_pREAL) stt%relaxationVector => homogState(ho)%state(1:nIntFaceTot,:) st0%relaxationVector => homogState(ho)%state0(1:nIntFaceTot,:) - allocate(dst%volumeDiscrepancy( Nmembers), source=0.0_pReal) - allocate(dst%relaxationRate_avg( Nmembers), source=0.0_pReal) - allocate(dst%relaxationRate_max( Nmembers), source=0.0_pReal) - allocate(dst%mismatch( 3,Nmembers), source=0.0_pReal) + allocate(dst%volumeDiscrepancy( Nmembers), source=0.0_pREAL) + allocate(dst%relaxationRate_avg( Nmembers), source=0.0_pREAL) + allocate(dst%relaxationRate_max( Nmembers), source=0.0_pREAL) + allocate(dst%mismatch( 3,Nmembers), source=0.0_pREAL) !-------------------------------------------------------------------------------------------------- ! assigning cluster orientations @@ -197,13 +197,13 @@ end subroutine RGC_init !-------------------------------------------------------------------------------------------------- module subroutine RGC_partitionDeformation(F,avgF,ce) - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned F per grain + real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned F per grain - real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F + real(pREAL), dimension (3,3), intent(in) :: avgF !< averaged F integer, intent(in) :: & ce - real(pReal), dimension(3) :: aVect,nVect + real(pREAL), dimension(3) :: aVect,nVect integer, dimension(4) :: intFace integer, dimension(3) :: iGrain3 integer :: iGrain,iFace,i,j,ho,en @@ -214,7 +214,7 @@ module subroutine RGC_partitionDeformation(F,avgF,ce) en = material_entry_homogenization(ce) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations - F = 0.0_pReal + F = 0.0_pREAL do iGrain = 1,product(prm%N_constituents) iGrain3 = grain1to3(iGrain,prm%N_constituents) do iFace = 1,6 @@ -238,25 +238,25 @@ end subroutine RGC_partitionDeformation !-------------------------------------------------------------------------------------------------- module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) logical, dimension(2) :: doneAndHappy - real(pReal), dimension(:,:,:), intent(in) :: & + real(pREAL), dimension(:,:,:), intent(in) :: & P,& !< partitioned stresses F !< partitioned deformation gradients - real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - real(pReal), dimension(3,3), intent(in) :: avgF !< average F - real(pReal), intent(in) :: dt !< time increment + real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + real(pREAL), dimension(3,3), intent(in) :: avgF !< average F + real(pREAL), intent(in) :: dt !< time increment integer, intent(in) :: & ce !< cell integer, dimension(4) :: intFaceN,intFaceP,faceID integer, dimension(3) :: nGDim,iGr3N,iGr3P integer :: ho,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,nGrain, en - real(pReal), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD - real(pReal), dimension(3,size(P,3)) :: NN,devNull - real(pReal), dimension(3) :: normP,normN,mornP,mornN - real(pReal) :: residMax,stresMax + real(pREAL), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD + real(pREAL), dimension(3,size(P,3)) :: NN,devNull + real(pREAL), dimension(3) :: normP,normN,mornP,mornN + real(pREAL) :: residMax,stresMax logical :: error - real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix - real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax + real(pREAL), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix + real(pREAL), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax zeroTimeStep: if (dEq0(dt)) then doneAndHappy = .true. ! pretend everything is fine and return @@ -278,8 +278,8 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster - allocate(resid(3*nIntFaceTot), source=0.0_pReal) - allocate(tract(nIntFaceTot,3), source=0.0_pReal) + allocate(resid(3*nIntFaceTot), source=0.0_pREAL) + allocate(tract(nIntFaceTot,3), source=0.0_pREAL) relax = stt%relaxationVector(:,en) drelax = stt%relaxationVector(:,en) - st0%relaxationVector(:,en) @@ -337,8 +337,8 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) if (residMax < num%rtol*stresMax .or. residMax < num%atol) then doneAndHappy = .true. - dst%mismatch(1:3,en) = sum(NN,2)/real(nGrain,pReal) - dst%relaxationRate_avg(en) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pReal) + dst%mismatch(1:3,en) = sum(NN,2)/real(nGrain,pREAL) + dst%relaxationRate_avg(en) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pREAL) dst%relaxationRate_max(en) = maxval(abs(drelax))/dt return @@ -356,7 +356,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" - allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) + allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL) do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(ho)%N_constituents) ! assembling of local dPdF into global Jacobian matrix @@ -403,9 +403,9 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical ! perturbation method) "pmatrix" - allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) - allocate(p_relax(3*nIntFaceTot), source=0.0_pReal) - allocate(p_resid(3*nIntFaceTot), source=0.0_pReal) + allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL) + allocate(p_relax(3*nIntFaceTot), source=0.0_pREAL) + allocate(p_resid(3*nIntFaceTot), source=0.0_pREAL) do ipert = 1,3*nIntFaceTot p_relax = relax @@ -417,7 +417,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state - p_resid = 0.0_pReal + p_resid = 0.0_pREAL do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(ho)%N_constituents) ! identifying the interface ID in local coordinate system (4-dimensional index) @@ -452,10 +452,10 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! ... of the numerical viscosity traction "rmatrix" - allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) + allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pREAL) do i=1,3*nIntFaceTot rmatrix(i,i) = num%viscModus*num%viscPower/(num%refRelaxRate*dt)* & ! tangent due to numerical viscosity traction appears - (abs(drelax(i))/(num%refRelaxRate*dt))**(num%viscPower - 1.0_pReal) ! only in the main diagonal term + (abs(drelax(i))/(num%refRelaxRate*dt))**(num%viscPower - 1.0_pREAL) ! only in the main diagonal term end do @@ -465,12 +465,12 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix - allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) + allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pREAL) call math_invert(jnverse,error,jmatrix) !-------------------------------------------------------------------------------------------------- ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration - drelax = 0.0_pReal + drelax = 0.0_pREAL do i = 1,3*nIntFaceTot;do j = 1,3*nIntFaceTot drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable end do; end do @@ -492,26 +492,26 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !------------------------------------------------------------------------------------------------ subroutine stressPenalty(rPen,nMis,avgF,fDef,ho,en) - real(pReal), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty - real(pReal), dimension (:,:), intent(out) :: nMis !< total amount of mismatch + real(pREAL), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty + real(pREAL), dimension (:,:), intent(out) :: nMis !< total amount of mismatch - real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients - real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor + real(pREAL), dimension (:,:,:), intent(in) :: fDef !< deformation gradients + real(pREAL), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor integer, intent(in) :: ho, en integer, dimension (4) :: intFace integer, dimension (3) :: iGrain3,iGNghb3,nGDim - real(pReal), dimension (3,3) :: gDef,nDef - real(pReal), dimension (3) :: nVect,surfCorr + real(pREAL), dimension (3,3) :: gDef,nDef + real(pREAL), dimension (3) :: nVect,surfCorr integer :: iGrain,iGNghb,iFace,i,j,k,l - real(pReal) :: muGrain,muGNghb,nDefNorm - real(pReal), parameter :: & - nDefToler = 1.0e-10_pReal, & - b = 2.5e-10_pReal ! Length of Burgers vector + real(pREAL) :: muGrain,muGNghb,nDefNorm + real(pREAL), parameter :: & + nDefToler = 1.0e-10_pREAL, & + b = 2.5e-10_pREAL ! Length of Burgers vector nGDim = param(ho)%N_constituents - rPen = 0.0_pReal - nMis = 0.0_pReal + rPen = 0.0_pREAL + nMis = 0.0_pREAL !---------------------------------------------------------------------------------------------- ! get the correction factor the modulus of penalty stress representing the evolution of area of @@ -532,17 +532,17 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) nVect = interfaceNormal(intFace,ho,en) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & - + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal)) + + int(real(intFace(1),pREAL)/real(abs(intFace(1)),pREAL)) where(iGNghb3 < 1) iGNghb3 = nGDim where(iGNghb3 >nGDim) iGNghb3 = 1 iGNghb = grain3to1(iGNghb3,prm%N_constituents) ! get the ID of the neighboring grain muGNghb = equivalentMu(iGNghb,ce) - gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! difference/jump in deformation gradeint across the neighbor + gDef = 0.5_pREAL*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! difference/jump in deformation gradeint across the neighbor !------------------------------------------------------------------------------------------- ! compute the mismatch tensor of all interfaces - nDefNorm = 0.0_pReal - nDef = 0.0_pReal + nDefNorm = 0.0_pREAL + nDef = 0.0_pREAL do i = 1,3; do j = 1,3 do k = 1,3; do l = 1,3 nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_LeviCivita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient @@ -556,10 +556,10 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !------------------------------------------------------------------------------------------- ! compute the stress penalty of all interfaces do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3 - rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*b + muGNghb*b)*prm%xi_alpha & + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pREAL*(muGrain*b + muGNghb*b)*prm%xi_alpha & *surfCorr(abs(intFace(1)))/prm%D_alpha(abs(intFace(1))) & *cosh(prm%c_alpha*nDefNorm) & - *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_LeviCivita(k,l,j) & + *0.5_pREAL*nVect(l)*nDef(i,k)/nDefNorm*math_LeviCivita(k,l,j) & *tanh(nDefNorm/num%xSmoo) end do; end do;end do; end do end do interfaceLoop @@ -577,15 +577,15 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !------------------------------------------------------------------------------------------------ subroutine volumePenalty(vPen,vDiscrep,fAvg,fDef,nGrain) - real(pReal), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume - real(pReal), intent(out) :: vDiscrep ! total volume discrepancy + real(pREAL), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume + real(pREAL), intent(out) :: vDiscrep ! total volume discrepancy - real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients - real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient + real(pREAL), dimension (:,:,:), intent(in) :: fDef ! deformation gradients + real(pREAL), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient integer, intent(in) :: & Ngrain - real(pReal), dimension(size(vPen,3)) :: gVol + real(pREAL), dimension(size(vPen,3)) :: gVol integer :: i !---------------------------------------------------------------------------------------------- @@ -593,16 +593,16 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) vDiscrep = math_det33(fAvg) ! compute the volume of the cluster do i = 1,nGrain gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains - vDiscrep = vDiscrep - gVol(i)/real(nGrain,pReal) ! calculate the difference/dicrepancy between + vDiscrep = vDiscrep - gVol(i)/real(nGrain,pREAL) ! calculate the difference/dicrepancy between ! the volume of the cluster and the the total volume of grains end do !---------------------------------------------------------------------------------------------- ! calculate the stress and penalty due to volume discrepancy - vPen = 0.0_pReal + vPen = 0.0_pREAL do i = 1,nGrain - vPen(:,:,i) = -real(nGrain,pReal)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr & - * sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pReal),vDiscrep) & + vPen(:,:,i) = -real(nGrain,pREAL)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr & + * sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pREAL),vDiscrep) & * gVol(i)*transpose(math_inv33(fDef(:,:,i))) end do @@ -615,21 +615,21 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !-------------------------------------------------------------------------------------------------- function surfaceCorrection(avgF,ho,en) - real(pReal), dimension(3) :: surfaceCorrection + real(pREAL), dimension(3) :: surfaceCorrection - real(pReal), dimension(3,3), intent(in) :: avgF !< average F + real(pREAL), dimension(3,3), intent(in) :: avgF !< average F integer, intent(in) :: & ho, & en - real(pReal), dimension(3,3) :: invC - real(pReal), dimension(3) :: nVect - real(pReal) :: detF + real(pREAL), dimension(3,3) :: invC + real(pREAL), dimension(3) :: nVect + real(pREAL) :: detF integer :: i,j,iBase logical :: error call math_invert33(invC,detF,error,matmul(transpose(avgF),avgF)) - surfaceCorrection = 0.0_pReal + surfaceCorrection = 0.0_pREAL do iBase = 1,3 nVect = interfaceNormal([iBase,1,1,1],ho,en) do i = 1,3; do j = 1,3 @@ -644,13 +644,13 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !------------------------------------------------------------------------------------------------- !> @brief compute the equivalent shear and bulk moduli from the elasticity tensor !------------------------------------------------------------------------------------------------- - real(pReal) function equivalentMu(co,ce) + real(pREAL) function equivalentMu(co,ce) integer, intent(in) :: & co,& ce - real(pReal), dimension(6,6) :: C + real(pREAL), dimension(6,6) :: C C = phase_homogenizedC66(material_ID_phase(co,ce),material_entry_phase(co,ce)) ! damage not included! @@ -665,14 +665,14 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) !------------------------------------------------------------------------------------------------- subroutine grainDeformation(F, avgF, ho, en) - real(pReal), dimension(:,:,:), intent(out) :: F !< partitioned F per grain + real(pREAL), dimension(:,:,:), intent(out) :: F !< partitioned F per grain - real(pReal), dimension(:,:), intent(in) :: avgF !< averaged F + real(pREAL), dimension(:,:), intent(in) :: avgF !< averaged F integer, intent(in) :: & ho, & en - real(pReal), dimension(3) :: aVect,nVect + real(pREAL), dimension(3) :: aVect,nVect integer, dimension(4) :: intFace integer, dimension(3) :: iGrain3 integer :: iGrain,iFace,i,j @@ -682,7 +682,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) associate (prm => param(ho)) - F = 0.0_pReal + F = 0.0_pREAL do iGrain = 1,product(prm%N_constituents) iGrain3 = grain1to3(iGrain,prm%N_constituents) do iFace = 1,6 @@ -739,7 +739,7 @@ end subroutine RGC_result !-------------------------------------------------------------------------------------------------- pure function relaxationVector(intFace,ho,en) - real(pReal), dimension (3) :: relaxationVector + real(pREAL), dimension (3) :: relaxationVector integer, intent(in) :: ho,en integer, dimension(4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) @@ -756,7 +756,7 @@ pure function relaxationVector(intFace,ho,en) if (iNum > 0) then relaxationVector = stt%relaxationVector((3*iNum-2):(3*iNum),en) else - relaxationVector = 0.0_pReal + relaxationVector = 0.0_pREAL end if end associate @@ -769,7 +769,7 @@ end function relaxationVector !-------------------------------------------------------------------------------------------------- pure function interfaceNormal(intFace,ho,en) result(n) - real(pReal), dimension(3) :: n + real(pREAL), dimension(3) :: n integer, dimension(4), intent(in) :: intFace !< interface ID in 4D array (normal and position) integer, intent(in) :: & ho, & @@ -778,8 +778,8 @@ pure function interfaceNormal(intFace,ho,en) result(n) associate (dst => dependentState(ho)) - n = 0.0_pReal - n(abs(intFace(1))) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis + n = 0.0_pREAL + n(abs(intFace(1))) = real(intFace(1)/abs(intFace(1)),pREAL) ! get the normal vector w.r.t. cluster axis n = matmul(dst%orientation(1:3,1:3,en),n) ! map the normal vector into sample coordinate system (basis) @@ -800,7 +800,7 @@ pure function getInterface(iFace,iGrain3) result(i) integer :: iDir !< direction of interface normal - iDir = (int(real(iFace-1,pReal)/2.0_pReal)+1)*(-1)**iFace + iDir = (int(real(iFace-1,pREAL)/2.0_pREAL)+1)*(-1)**iFace i = [iDir,iGrain3] if (iDir < 0) i(1-iDir) = i(1-iDir)-1 ! to have a correlation with coordinate/position in real space @@ -907,18 +907,18 @@ pure function interface1to4(iFace1D, nGDim) if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal || e1 interface1to4(1) = 1 interface1to4(3) = mod((iFace1D-1),nGDim(2))+1 - interface1to4(4) = mod(int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)),nGDim(3))+1 - interface1to4(2) = int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)/real(nGDim(3),pReal))+1 + interface1to4(4) = mod(int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)),nGDim(3))+1 + interface1to4(2) = int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)/real(nGDim(3),pREAL))+1 elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal || e2 interface1to4(1) = 2 interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1 - interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)),nGDim(1))+1 - interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)/real(nGDim(1),pReal))+1 + interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)),nGDim(1))+1 + interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)/real(nGDim(1),pREAL))+1 elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal || e3 interface1to4(1) = 3 interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1 - interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)),nGDim(2))+1 - interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)/real(nGDim(2),pReal))+1 + interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pREAL)/real(nGDim(1),pREAL)),nGDim(2))+1 + interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pREAL)/real(nGDim(1),pREAL)/real(nGDim(2),pREAL))+1 end if end function interface1to4 diff --git a/src/homogenization_mechanical_isostrain.f90 b/src/homogenization_mechanical_isostrain.f90 index 3a603196f..a3807cb87 100644 --- a/src/homogenization_mechanical_isostrain.f90 +++ b/src/homogenization_mechanical_isostrain.f90 @@ -40,9 +40,9 @@ end subroutine isostrain_init !-------------------------------------------------------------------------------------------------- module subroutine isostrain_partitionDeformation(F,avgF) - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point F = spread(avgF,3,size(F,3)) diff --git a/src/homogenization_thermal.f90 b/src/homogenization_thermal.f90 index 27dc57db4..789ac994b 100644 --- a/src/homogenization_thermal.f90 +++ b/src/homogenization_thermal.f90 @@ -14,7 +14,7 @@ submodule(homogenization) thermal end interface type :: tDataContainer - real(pReal), dimension(:), allocatable :: T, dot_T + real(pREAL), dimension(:), allocatable :: T, dot_T end type tDataContainer type(tDataContainer), dimension(:), allocatable :: current @@ -51,7 +51,7 @@ module subroutine thermal_init() do ho = 1, configHomogenizations%length allocate(current(ho)%T(count(material_ID_homogenization==ho)), source=T_ROOM) - allocate(current(ho)%dot_T(count(material_ID_homogenization==ho)), source=0.0_pReal) + allocate(current(ho)%dot_T(count(material_ID_homogenization==ho)), source=0.0_pREAL) configHomogenization => configHomogenizations%get_dict(ho) associate(prm => param(ho)) @@ -100,7 +100,7 @@ module subroutine thermal_partition(ce) integer, intent(in) :: ce - real(pReal) :: T, dot_T + real(pREAL) :: T, dot_T integer :: co @@ -119,7 +119,7 @@ end subroutine thermal_partition module function homogenization_mu_T(ce) result(mu) integer, intent(in) :: ce - real(pReal) :: mu + real(pREAL) :: mu integer :: co @@ -138,7 +138,7 @@ end function homogenization_mu_T module function homogenization_K_T(ce) result(K) integer, intent(in) :: ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K integer :: co @@ -157,7 +157,7 @@ end function homogenization_K_T module function homogenization_f_T(ce) result(f) integer, intent(in) :: ce - real(pReal) :: f + real(pREAL) :: f integer :: co @@ -176,7 +176,7 @@ end function homogenization_f_T module subroutine homogenization_thermal_setField(T,dot_T, ce) integer, intent(in) :: ce - real(pReal), intent(in) :: T, dot_T + real(pREAL), intent(in) :: T, dot_T current(material_ID_homogenization(ce))%T(material_entry_homogenization(ce)) = T diff --git a/src/lattice.f90 b/src/lattice.f90 index 5cb254012..350860ecb 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -38,7 +38,7 @@ module lattice CF_NTRANS = sum(CF_NTRANSSYSTEM), & !< total # of transformation systems for cF CF_NCLEAVAGE = sum(CF_NCLEAVAGESYSTEM) !< total # of cleavage systems for cF - real(pReal), dimension(3+3,CF_NSLIP), parameter :: & + real(pREAL), dimension(3+3,CF_NSLIP), parameter :: & CF_SYSTEMSLIP = reshape(real([& ! <110>{111} systems 0, 1,-1, 1, 1, 1, & ! B2 @@ -60,9 +60,9 @@ module lattice 1, 0,-1, 1, 0, 1, & 0, 1, 1, 0, 1,-1, & 0, 1,-1, 0, 1, 1 & - ],pReal),shape(CF_SYSTEMSLIP)) !< cF slip systems + ],pREAL),shape(CF_SYSTEMSLIP)) !< cF slip systems - real(pReal), dimension(3+3,CF_NTWIN), parameter :: & + real(pREAL), dimension(3+3,CF_NTWIN), parameter :: & CF_SYSTEMTWIN = reshape(real( [& ! <112>{111} systems -2, 1, 1, 1, 1, 1, & @@ -77,7 +77,7 @@ module lattice 2, 1,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, & -1, 1, 2, -1, 1,-1 & - ],pReal),shape(CF_SYSTEMTWIN)) !< cF twin systems + ],pREAL),shape(CF_SYSTEMTWIN)) !< cF twin systems integer, dimension(2,CF_NTWIN), parameter, public :: & lattice_CF_TWINNUCLEATIONSLIPPAIR = reshape( [& @@ -95,13 +95,13 @@ module lattice 10,11 & ],shape(lattice_CF_TWINNUCLEATIONSLIPPAIR)) - real(pReal), dimension(3+3,CF_NCLEAVAGE), parameter :: & + real(pREAL), dimension(3+3,CF_NCLEAVAGE), parameter :: & CF_SYSTEMCLEAVAGE = reshape(real([& ! <001>{001} systems 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, & 1, 0, 0, 0, 0, 1 & - ],pReal),shape(CF_SYSTEMCLEAVAGE)) !< cF cleavage systems + ],pREAL),shape(CF_SYSTEMCLEAVAGE)) !< cF cleavage systems !-------------------------------------------------------------------------------------------------- ! cI: body centered cubic (bcc) @@ -120,7 +120,7 @@ module lattice CI_NTWIN = sum(CI_NTWINSYSTEM), & !< total # of twin systems for cI CI_NCLEAVAGE = sum(CI_NCLEAVAGESYSTEM) !< total # of cleavage systems for cI - real(pReal), dimension(3+3,CI_NSLIP), parameter :: & + real(pREAL), dimension(3+3,CI_NSLIP), parameter :: & CI_SYSTEMSLIP = reshape(real([& ! <111>{110} systems 1,-1, 1, 0, 1, 1, & ! D1 @@ -173,9 +173,9 @@ module lattice 1, 1, 1, -3, 2, 1, & 1, 1,-1, 3,-2, 1, & 1,-1, 1, 3, 2,-1 & - ],pReal),shape(CI_SYSTEMSLIP)) !< cI slip systems + ],pREAL),shape(CI_SYSTEMSLIP)) !< cI slip systems - real(pReal), dimension(3+3,CI_NTWIN), parameter :: & + real(pREAL), dimension(3+3,CI_NTWIN), parameter :: & CI_SYSTEMTWIN = reshape(real([& ! <111>{112} systems -1, 1, 1, 2, 1, 1, & @@ -190,15 +190,15 @@ module lattice 1,-1, 1, -1, 1, 2, & -1, 1, 1, 1,-1, 2, & 1, 1, 1, 1, 1,-2 & - ],pReal),shape(CI_SYSTEMTWIN)) !< cI twin systems + ],pREAL),shape(CI_SYSTEMTWIN)) !< cI twin systems - real(pReal), dimension(3+3,CI_NCLEAVAGE), parameter :: & + real(pREAL), dimension(3+3,CI_NCLEAVAGE), parameter :: & CI_SYSTEMCLEAVAGE = reshape(real([& ! <001>{001} systems 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, & 1, 0, 0, 0, 0, 1 & - ],pReal),shape(CI_SYSTEMCLEAVAGE)) !< cI cleavage systems + ],pREAL),shape(CI_SYSTEMCLEAVAGE)) !< cI cleavage systems !-------------------------------------------------------------------------------------------------- ! hP: hexagonal [close packed] (hex, hcp) @@ -213,7 +213,7 @@ module lattice HP_NSLIP = sum(HP_NSLIPSYSTEM), & !< total # of slip systems for hP HP_NTWIN = sum(HP_NTWINSYSTEM) !< total # of twin systems for hP - real(pReal), dimension(4+4,HP_NSLIP), parameter :: & + real(pREAL), dimension(4+4,HP_NSLIP), parameter :: & HP_SYSTEMSLIP = reshape(real([& ! <-1-1.0>{00.1}/basal systems (independent of c/a-ratio) 2, -1, -1, 0, 0, 0, 0, 1, & @@ -250,9 +250,9 @@ module lattice 1, 1, -2, 3, -1, -1, 2, 2, & -1, 2, -1, 3, 1, -2, 1, 2, & -2, 1, 1, 3, 2, -1, -1, 2 & - ],pReal),shape(HP_SYSTEMSLIP)) !< hP slip systems, sorted by P. Eisenlohr CCW around starting next to a_1 axis + ],pREAL),shape(HP_SYSTEMSLIP)) !< hP slip systems, sorted by P. Eisenlohr CCW around starting next to a_1 axis - real(pReal), dimension(4+4,HP_NTWIN), parameter :: & + real(pREAL), dimension(4+4,HP_NTWIN), parameter :: & HP_SYSTEMTWIN = reshape(real([& ! <-10.1>{10.2} systems, shear = (3-(c/a)^2)/(sqrt(3) c/a) ! tension in Co, Mg, Zr, Ti, and Be; compression in Cd and Zn @@ -286,7 +286,7 @@ module lattice -1, -1, 2, -3, -1, -1, 2, 2, & 1, -2, 1, -3, 1, -2, 1, 2, & 2, -1, -1, -3, 2, -1, -1, 2 & - ],pReal),shape(HP_SYSTEMTWIN)) !< hP twin systems, sorted by P. Eisenlohr CCW around starting next to a_1 axis + ],pREAL),shape(HP_SYSTEMTWIN)) !< hP twin systems, sorted by P. Eisenlohr CCW around starting next to a_1 axis !-------------------------------------------------------------------------------------------------- ! tI: body centered tetragonal (bct) @@ -297,7 +297,7 @@ module lattice integer, parameter :: & TI_NSLIP = sum(TI_NSLIPSYSTEM) !< total # of slip systems for tI - real(pReal), dimension(3+3,TI_NSLIP), parameter :: & + real(pREAL), dimension(3+3,TI_NSLIP), parameter :: & TI_SYSTEMSLIP = reshape(real([& ! {100)<001] systems 0, 0, 1, 1, 0, 0, & @@ -364,7 +364,7 @@ module lattice 1,-1, 1, -2,-1, 1, & -1, 1, 1, -1,-2, 1, & 1, 1, 1, 1,-2, 1 & - ],pReal),shape(TI_SYSTEMSLIP)) !< tI slip systems for c/a = 0.5456 (Sn), sorted by Bieler 2009 (https://doi.org/10.1007/s11664-009-0909-x) + ],pREAL),shape(TI_SYSTEMSLIP)) !< tI slip systems for c/a = 0.5456 (Sn), sorted by Bieler 2009 (https://doi.org/10.1007/s11664-009-0909-x) interface lattice_forestProjection_edge @@ -424,8 +424,8 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Ntwin)) :: characteristicShear + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(sum(Ntwin)) :: characteristicShear integer :: & a, & !< index of active system @@ -467,20 +467,20 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character a = a + 1 select case(lattice) case('cF','cI') - characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) + characteristicShear(a) = 0.5_pREAL*sqrt(2.0_pREAL) case('hP') - if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & + if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & call IO_error(131,ext_msg='lattice_characteristicShear_Twin') p = sum(HP_NTWINSYSTEM(1:f-1))+s select case(HP_SHEARTWIN(p)) ! from Christian & Mahajan 1995 p.29 case (1) ! <-10.1>{10.2} - characteristicShear(a) = (3.0_pReal-cOverA**2)/sqrt(3.0_pReal)/CoverA + characteristicShear(a) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA case (2) ! <11.6>{-1-1.1} - characteristicShear(a) = 1.0_pReal/cOverA + characteristicShear(a) = 1.0_pREAL/cOverA case (3) ! <10.-2>{10.1} - characteristicShear(a) = (4.0_pReal*cOverA**2-9.0_pReal)/sqrt(48.0_pReal)/cOverA + characteristicShear(a) = (4.0_pREAL*cOverA**2-9.0_pREAL)/sqrt(48.0_pREAL)/cOverA case (4) ! <11.-3>{11.2} - characteristicShear(a) = 2.0_pReal*(cOverA**2-2.0_pReal)/3.0_pReal/cOverA + characteristicShear(a) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA end select case default call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(lattice)) @@ -498,11 +498,11 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA) integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin + real(pREAL), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin - real(pReal), dimension(3,3,sum(Ntwin)):: coordinateSystem + real(pREAL), dimension(3,3,sum(Ntwin)):: coordinateSystem type(tRotation) :: R integer :: i @@ -510,10 +510,10 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA) select case(lattice) case('cF') coordinateSystem = buildCoordinateSystem(Ntwin,CF_NSLIPSYSTEM,CF_SYSTEMTWIN,& - lattice,0.0_pReal) + lattice,0.0_pREAL) case('cI') coordinateSystem = buildCoordinateSystem(Ntwin,CI_NSLIPSYSTEM,CI_SYSTEMTWIN,& - lattice,0.0_pReal) + lattice,0.0_pREAL) case('hP') coordinateSystem = buildCoordinateSystem(Ntwin,HP_NSLIPSYSTEM,HP_SYSTEMTWIN,& lattice,cOverA) @@ -537,12 +537,12 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, & integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol) - real(pReal), dimension(6,6), intent(in) :: C_parent66 - real(pReal), optional, intent(in) :: cOverA_trans, a_cF, a_cI - real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans + real(pREAL), dimension(6,6), intent(in) :: C_parent66 + real(pREAL), optional, intent(in) :: cOverA_trans, a_cF, a_cI + real(pREAL), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 - real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S + real(pREAL), dimension(6,6) :: C_bar66, C_target_unrotated66 + real(pREAL), dimension(3,3,sum(Ntrans)) :: Q,S type(tRotation) :: R integer :: i @@ -551,24 +551,24 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, & if (lattice_target == 'hP' .and. present(cOverA_trans)) then ! https://doi.org/10.1063/1.1663858 eq. (16), eq. (18), eq. (19) ! https://doi.org/10.1016/j.actamat.2016.07.032 eq. (47), eq. (48) - if (cOverA_trans < 1.0_pReal .or. cOverA_trans > 2.0_pReal) & + if (cOverA_trans < 1.0_pREAL .or. cOverA_trans > 2.0_pREAL) & call IO_error(131,ext_msg='lattice_C66_trans: '//trim(lattice_target)) - C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal - C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal - C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(1,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pReal - C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pReal*C_parent66(4,4)) /(3.0_pReal*sqrt(2.0_pReal)) + C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pREAL*C_parent66(4,4))/2.0_pREAL + C_bar66(1,2) = (C_parent66(1,1) + 5.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/6.0_pREAL + C_bar66(3,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) + 4.0_pREAL*C_parent66(4,4))/3.0_pREAL + C_bar66(1,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/3.0_pREAL + C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pREAL + C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4)) /(3.0_pREAL*sqrt(2.0_pREAL)) - C_target_unrotated66 = 0.0_pReal + C_target_unrotated66 = 0.0_pREAL C_target_unrotated66(1,1) = C_bar66(1,1) - C_bar66(1,4)**2/C_bar66(4,4) C_target_unrotated66(1,2) = C_bar66(1,2) + C_bar66(1,4)**2/C_bar66(4,4) C_target_unrotated66(1,3) = C_bar66(1,3) C_target_unrotated66(3,3) = C_bar66(3,3) - C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2/(0.5_pReal*(C_bar66(1,1) - C_bar66(1,2))) + C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2/(0.5_pREAL*(C_bar66(1,1) - C_bar66(1,2))) C_target_unrotated66 = lattice_symmetrize_C66(C_target_unrotated66,'hP') elseif (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then - if (a_cI <= 0.0_pReal .or. a_cF <= 0.0_pReal) & + if (a_cI <= 0.0_pREAL .or. a_cF <= 0.0_pREAL) & call IO_error(134,ext_msg='lattice_C66_trans: '//trim(lattice_target)) C_target_unrotated66 = C_parent66 else @@ -598,26 +598,26 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, & function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections + real(pREAL), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections integer, intent(in) :: sense !< sense (-1,+1) - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix + real(pREAL), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system - real(pReal), dimension(3) :: direction, normal, np + real(pREAL), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system + real(pREAL), dimension(3) :: direction, normal, np type(tRotation) :: R integer :: i if (abs(sense) /= 1) error stop 'Sense in lattice_nonSchmidMatrix' - coordinateSystem = buildCoordinateSystem(Nslip,CI_NSLIPSYSTEM,CI_SYSTEMSLIP,'cI',0.0_pReal) - coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip))*real(sense,pReal) ! convert unidirectional coordinate system - nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pReal) ! Schmid contribution + coordinateSystem = buildCoordinateSystem(Nslip,CI_NSLIPSYSTEM,CI_SYSTEMSLIP,'cI',0.0_pREAL) + coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip))*real(sense,pREAL) ! convert unidirectional coordinate system + nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pREAL) ! Schmid contribution do i = 1,sum(Nslip) direction = coordinateSystem(1:3,1,i) normal = coordinateSystem(1:3,2,i) - call R%fromAxisAngle([direction,60.0_pReal],degrees=.true.,P=1) + call R%fromAxisAngle([direction,60.0_pREAL],degrees=.true.,P=1) np = R%rotate(normal) if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & @@ -647,9 +647,9 @@ end function lattice_nonSchmidMatrix function lattice_interaction_SlipBySlip(Nslip,interactionValues,lattice) result(interactionMatrix) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction + real(pREAL), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix + real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix integer, dimension(:), allocatable :: NslipMax integer, dimension(:,:), allocatable :: interactionTypes @@ -965,9 +965,9 @@ end function lattice_interaction_SlipBySlip function lattice_interaction_TwinByTwin(Ntwin,interactionValues,lattice) result(interactionMatrix) integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction + real(pREAL), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix + real(pREAL), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix integer, dimension(:), allocatable :: NtwinMax integer, dimension(:,:), allocatable :: interactionTypes @@ -1064,9 +1064,9 @@ end function lattice_interaction_TwinByTwin function lattice_interaction_TransByTrans(Ntrans,interactionValues,lattice) result(interactionMatrix) integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction + real(pREAL), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction character(len=*), intent(in) :: lattice ! 2.0_pReal) & + if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & call IO_error(131,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target)) call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA=cOverA) else if (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then - if (a_cI <= 0.0_pReal .or. a_cF <= 0.0_pReal) & + if (a_cI <= 0.0_pREAL .or. a_cF <= 0.0_pREAL) & call IO_error(134,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target)) call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,a_cF=a_cF,a_cI=a_cI) else @@ -1522,11 +1522,11 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,lattice,cOverA) result(SchmidMa integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix - real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: cleavageSystems + real(pREAL), dimension(3,3,sum(Ncleavage)) :: coordinateSystem + real(pREAL), dimension(:,:), allocatable :: cleavageSystems integer, dimension(:), allocatable :: NcleavageMax integer :: i @@ -1565,10 +1565,10 @@ function lattice_slip_direction(Nslip,lattice,cOverA) result(d) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: d + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(3,sum(Nslip)) :: d - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) d = coordinateSystem(1:3,1,1:sum(Nslip)) @@ -1583,10 +1583,10 @@ function lattice_slip_normal(Nslip,lattice,cOverA) result(n) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: n + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(3,sum(Nslip)) :: n - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) n = coordinateSystem(1:3,2,1:sum(Nslip)) @@ -1601,10 +1601,10 @@ function lattice_slip_transverse(Nslip,lattice,cOverA) result(t) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: t + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(3,sum(Nslip)) :: t - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) t = coordinateSystem(1:3,3,1:sum(Nslip)) @@ -1623,7 +1623,7 @@ function lattice_labels_slip(Nslip,lattice) result(labels) character(len=:), dimension(:), allocatable :: labels - real(pReal), dimension(:,:), allocatable :: slipSystems + real(pREAL), dimension(:,:), allocatable :: slipSystems integer, dimension(:), allocatable :: NslipMax select case(lattice) @@ -1658,13 +1658,13 @@ end function lattice_labels_slip !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrize_33(T,lattice) result(T_sym) - real(pReal), dimension(3,3) :: T_sym + real(pREAL), dimension(3,3) :: T_sym - real(pReal), dimension(3,3), intent(in) :: T + real(pREAL), dimension(3,3), intent(in) :: T character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - T_sym = 0.0_pReal + T_sym = 0.0_pREAL select case(lattice) case('cF','cI') @@ -1686,15 +1686,15 @@ end function lattice_symmetrize_33 !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym) - real(pReal), dimension(6,6) :: C66_sym + real(pREAL), dimension(6,6) :: C66_sym - real(pReal), dimension(6,6), intent(in) :: C66 + real(pREAL), dimension(6,6), intent(in) :: C66 character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) integer :: i,j - C66_sym = 0.0_pReal + C66_sym = 0.0_pREAL select case(lattice) case ('cF','cI') @@ -1707,7 +1707,7 @@ pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym) C66_sym(1,2) = C66(1,2) C66_sym(1,3) = C66(1,3); C66_sym(2,3) = C66(1,3) C66_sym(4,4) = C66(4,4); C66_sym(5,5) = C66(4,4) - C66_sym(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) + C66_sym(6,6) = 0.5_pREAL*(C66(1,1)-C66(1,2)) case ('tI') C66_sym(1,1) = C66(1,1); C66_sym(2,2) = C66(1,1) C66_sym(3,3) = C66(3,3) @@ -1737,7 +1737,7 @@ function lattice_labels_twin(Ntwin,lattice) result(labels) character(len=:), dimension(:), allocatable :: labels - real(pReal), dimension(:,:), allocatable :: twinSystems + real(pREAL), dimension(:,:), allocatable :: twinSystems integer, dimension(:), allocatable :: NtwinMax select case(lattice) @@ -1772,10 +1772,10 @@ function slipProjection_transverse(Nslip,lattice,cOverA) result(projection) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: projection - real(pReal), dimension(3,sum(Nslip)) :: n, t + real(pREAL), dimension(3,sum(Nslip)) :: n, t integer :: i, j n = lattice_slip_normal (Nslip,lattice,cOverA) @@ -1796,10 +1796,10 @@ function slipProjection_direction(Nslip,lattice,cOverA) result(projection) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: projection - real(pReal), dimension(3,sum(Nslip)) :: n, d + real(pREAL), dimension(3,sum(Nslip)) :: n, d integer :: i, j n = lattice_slip_normal (Nslip,lattice,cOverA) @@ -1820,10 +1820,10 @@ function coordinateSystem_slip(Nslip,lattice,cOverA) result(coordinateSystem) integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pREAL), intent(in) :: cOverA !< c/a ratio + real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: slipSystems + real(pREAL), dimension(:,:), allocatable :: slipSystems integer, dimension(:), allocatable :: NslipMax select case(lattice) @@ -1864,9 +1864,9 @@ function buildInteraction(reacting_used,acting_used,reacting_max,acting_max,valu acting_used, & !< # of acting systems per family as specified in material.config reacting_max, & !< max # of reacting systems per family for given lattice acting_max !< max # of acting systems per family for given lattice - real(pReal), dimension(:), intent(in) :: values !< interaction values + real(pREAL), dimension(:), intent(in) :: values !< interaction values integer, dimension(:,:), intent(in) :: matrix !< interaction types - real(pReal), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction + real(pREAL), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction integer :: & acting_family_index, acting_family, acting_system, & @@ -1906,16 +1906,16 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA) integer, dimension(:), intent(in) :: & active, & !< # of active systems per family potential !< # of potential systems per family - real(pReal), dimension(:,:), intent(in) :: & + real(pREAL), dimension(:,:), intent(in) :: & system character(len=*), intent(in) :: & lattice !< Bravais lattice (Pearson symbol) - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & cOverA - real(pReal), dimension(3,3,sum(active)) :: & + real(pREAL), dimension(3,3,sum(active)) :: & buildCoordinateSystem - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & direction, normal integer :: & a, & !< index of active system @@ -1923,9 +1923,9 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA) f, & !< index of my family s !< index of my system in current family - if (lattice == 'tI' .and. cOverA > 2.0_pReal) & + if (lattice == 'tI' .and. cOverA > 2.0_pREAL) & call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice)) - if (lattice == 'hP' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & + if (lattice == 'hP' .and. (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL)) & call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice)) a = 0 @@ -1941,11 +1941,11 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA) normal = system(4:6,p) case ('hP') - direction = [ system(1,p)*1.5_pReal, & - (system(1,p)+2.0_pReal*system(2,p))*sqrt(0.75_pReal), & + direction = [ system(1,p)*1.5_pREAL, & + (system(1,p)+2.0_pREAL*system(2,p))*sqrt(0.75_pREAL), & system(4,p)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)]) normal = [ system(5,p), & - (system(5,p)+2.0_pReal*system(6,p))/sqrt(3.0_pReal), & + (system(5,p)+2.0_pREAL*system(6,p))/sqrt(3.0_pREAL), & system(8,p)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a)) case default @@ -1974,10 +1974,10 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) integer, dimension(:), intent(in) :: & Ntrans - real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & + real(pREAL), dimension(3,3,sum(Ntrans)), intent(out) :: & Q, & !< Total rotation: Q = R*B S !< Eigendeformation tensor for phase transformation - real(pReal), optional, intent(in) :: & + real(pREAL), optional, intent(in) :: & cOverA, & !< c/a for target hP lattice a_cF, & !< lattice parameter a for cF target lattice a_cI !< lattice parameter a for cI parent lattice @@ -1985,14 +1985,14 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) type(tRotation) :: & R, & !< Pitsch rotation B !< Rotation of cF to Bain coordinate system - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & U, & !< Bain deformation ss, sd - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & x, y, z integer :: & i - real(pReal), dimension(3+3,CF_NTRANS), parameter :: & + real(pREAL), dimension(3+3,CF_NTRANS), parameter :: & CFTOHP_SYSTEMTRANS = reshape(real( [& -2, 1, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, & @@ -2006,9 +2006,9 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) 2, 1,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, & -1, 1, 2, -1, 1,-1 & - ],pReal),shape(CFTOHP_SYSTEMTRANS)) + ],pREAL),shape(CFTOHP_SYSTEMTRANS)) - real(pReal), dimension(4,cF_Ntrans), parameter :: & + real(pREAL), dimension(4,cF_Ntrans), parameter :: & CFTOCI_SYSTEMTRANS = real(reshape([& 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) 0.0,-1.0, 0.0, 10.26, & @@ -2022,7 +2022,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) -1.0, 0.0, 0.0, 10.26, & 0.0, 1.0, 0.0, 10.26, & 0.0,-1.0, 0.0, 10.26 & - ],shape(CFTOCI_SYSTEMTRANS)),pReal) + ],shape(CFTOCI_SYSTEMTRANS)),pREAL) integer, dimension(9,cF_Ntrans), parameter :: & CFTOCI_BAINVARIANT = reshape( [& @@ -2040,7 +2040,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) 0, 0, 1, 1, 0, 0, 0, 1, 0 & ],shape(CFTOCI_BAINVARIANT)) - real(pReal), dimension(4,cF_Ntrans), parameter :: & + real(pREAL), dimension(4,cF_Ntrans), parameter :: & CFTOCI_BAINROT = real(reshape([& 1.0, 0.0, 0.0, 45.0, & ! Rotate cF austensite to bain variant 1.0, 0.0, 0.0, 45.0, & @@ -2054,25 +2054,25 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI) 0.0, 0.0, 1.0, 45.0, & 0.0, 0.0, 1.0, 45.0, & 0.0, 0.0, 1.0, 45.0 & - ],shape(CFTOCI_BAINROT)),pReal) + ],shape(CFTOCI_BAINROT)),pREAL) if (present(a_cI) .and. present(a_cF)) then do i = 1,sum(Ntrans) call R%fromAxisAngle(CFTOCI_SYSTEMTRANS(:,i),degrees=.true.,P=1) call B%fromAxisAngle(CFTOCI_BAINROT(:,i), degrees=.true.,P=1) - x = real(CFTOCI_BAINVARIANT(1:3,i),pReal) - y = real(CFTOCI_BAINVARIANT(4:6,i),pReal) - z = real(CFTOCI_BAINVARIANT(7:9,i),pReal) + x = real(CFTOCI_BAINVARIANT(1:3,i),pREAL) + y = real(CFTOCI_BAINVARIANT(4:6,i),pREAL) + z = real(CFTOCI_BAINVARIANT(7:9,i),pREAL) - U = (a_cI/a_cF) * (math_outer(x,x) + (math_outer(y,y)+math_outer(z,z)) * sqrt(2.0_pReal)) + U = (a_cI/a_cF) * (math_outer(x,x) + (math_outer(y,y)+math_outer(z,z)) * sqrt(2.0_pREAL)) Q(1:3,1:3,i) = matmul(R%asMatrix(),B%asMatrix()) S(1:3,1:3,i) = matmul(R%asMatrix(),U) - MATH_I3 end do else if (present(cOverA)) then ss = MATH_I3 sd = MATH_I3 - ss(1,3) = sqrt(2.0_pReal)/4.0_pReal - sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) + ss(1,3) = sqrt(2.0_pREAL)/4.0_pREAL + sd(3,3) = cOverA/sqrt(8.0_pREAL/3.0_pREAL) do i = 1,sum(Ntrans) x = CFTOHP_SYSTEMTRANS(1:3,i)/norm2(CFTOHP_SYSTEMTRANS(1:3,i)) @@ -2098,7 +2098,7 @@ function getlabels(active,potential,system) result(labels) integer, dimension(:), intent(in) :: & active, & !< # of active systems per family potential !< # of potential systems per family - real(pReal), dimension(:,:), intent(in) :: & + real(pREAL), dimension(:,:), intent(in) :: & system character(len=:), dimension(:), allocatable :: labels @@ -2152,28 +2152,28 @@ end function getlabels !-------------------------------------------------------------------------------------------------- pure function lattice_isotropic_nu(C,assumption,lattice) result(nu) - real(pReal), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) + real(pREAL), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss') character(len=*), optional, intent(in) :: lattice - real(pReal) :: nu + real(pREAL) :: nu - real(pReal) :: K, mu + real(pREAL) :: K, mu logical :: error - real(pReal), dimension(6,6) :: S + real(pREAL), dimension(6,6) :: S if (IO_lc(assumption) == 'isostrain') then - K = sum(C(1:3,1:3)) / 9.0_pReal + K = sum(C(1:3,1:3)) / 9.0_pREAL elseif (IO_lc(assumption) == 'isostress') then call math_invert(S,error,C) if (error) error stop 'matrix inversion failed' - K = 1.0_pReal / sum(S(1:3,1:3)) + K = 1.0_pREAL / sum(S(1:3,1:3)) else error stop 'invalid assumption' end if mu = lattice_isotropic_mu(C,assumption,lattice) - nu = (1.5_pReal*K-mu)/(3.0_pReal*K+mu) + nu = (1.5_pREAL*K-mu)/(3.0_pREAL*K+mu) end function lattice_isotropic_nu @@ -2185,36 +2185,36 @@ end function lattice_isotropic_nu !-------------------------------------------------------------------------------------------------- pure function lattice_isotropic_mu(C,assumption,lattice) result(mu) - real(pReal), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) + real(pREAL), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss') character(len=*), optional, intent(in) :: lattice - real(pReal) :: mu + real(pREAL) :: mu logical :: error - real(pReal), dimension(6,6) :: S + real(pREAL), dimension(6,6) :: S if (IO_lc(assumption) == 'isostrain') then select case(misc_optional(lattice,'')) case('cF','cI') - mu = ( C(1,1) - C(1,2) + C(4,4)*3.0_pReal) / 5.0_pReal + mu = ( C(1,1) - C(1,2) + C(4,4)*3.0_pREAL) / 5.0_pREAL case default mu = ( C(1,1)+C(2,2)+C(3,3) & - C(1,2)-C(2,3)-C(1,3) & - +(C(4,4)+C(5,5)+C(6,6)) * 3.0_pReal & - ) / 15.0_pReal + +(C(4,4)+C(5,5)+C(6,6)) * 3.0_pREAL & + ) / 15.0_pREAL end select elseif (IO_lc(assumption) == 'isostress') then select case(misc_optional(lattice,'')) case('cF','cI') - mu = 5.0_pReal & - / (4.0_pReal/(C(1,1)-C(1,2)) + 3.0_pReal/C(4,4)) + mu = 5.0_pREAL & + / (4.0_pREAL/(C(1,1)-C(1,2)) + 3.0_pREAL/C(4,4)) case default call math_invert(S,error,C) if (error) error stop 'matrix inversion failed' - mu = 15.0_pReal & - / (4.0_pReal*(S(1,1)+S(2,2)+S(3,3)-S(1,2)-S(2,3)-S(1,3)) + 3.0_pReal*(S(4,4)+S(5,5)+S(6,6))) + mu = 15.0_pREAL & + / (4.0_pREAL*(S(1,1)+S(2,2)+S(3,3)-S(1,2)-S(2,3)-S(1,3)) + 3.0_pREAL*(S(4,4)+S(5,5)+S(6,6))) end select else error stop 'invalid assumption' @@ -2228,20 +2228,20 @@ end function lattice_isotropic_mu !-------------------------------------------------------------------------------------------------- subroutine selfTest - real(pReal), dimension(:,:,:), allocatable :: CoSy - real(pReal), dimension(:,:), allocatable :: system + real(pREAL), dimension(:,:,:), allocatable :: CoSy + real(pREAL), dimension(:,:), allocatable :: system - real(pReal), dimension(6,6) :: C, C_cF, C_cI, C_hP, C_tI - real(pReal), dimension(3,3) :: T, T_cF, T_cI, T_hP, T_tI - real(pReal), dimension(2) :: r - real(pReal) :: lambda + real(pREAL), dimension(6,6) :: C, C_cF, C_cI, C_hP, C_tI + real(pREAL), dimension(3,3) :: T, T_cF, T_cI, T_hP, T_tI + real(pREAL), dimension(2) :: r + real(pREAL) :: lambda integer :: i call random_number(r) - system = reshape([1.0_pReal+r(1),0.0_pReal,0.0_pReal, 0.0_pReal,1.0_pReal+r(2),0.0_pReal],[6,1]) - CoSy = buildCoordinateSystem([1],[1],system,'cF',0.0_pReal) + system = reshape([1.0_pREAL+r(1),0.0_pREAL,0.0_pREAL, 0.0_pREAL,1.0_pREAL+r(2),0.0_pREAL],[6,1]) + CoSy = buildCoordinateSystem([1],[1],system,'cF',0.0_pREAL) if (any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem' do i = 1, 10 @@ -2274,9 +2274,9 @@ subroutine selfTest T_hP = lattice_symmetrize_33(T,'hP') T_tI = lattice_symmetrize_33(T,'tI') - if (any(dNeq0(T_cF) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/c' - if (any(dNeq0(T_hP) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/hP' - if (any(dNeq0(T_tI) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/tI' + if (any(dNeq0(T_cF) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/c' + if (any(dNeq0(T_hP) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/hP' + if (any(dNeq0(T_tI) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/tI' if (any(dNeq(T(1,1),[T_cI(1,1),T_cI(2,2),T_cI(3,3)]))) error stop 'Symmetry33_11-22-33/c' if (any(dNeq(T(1,1),[T_hP(1,1),T_hP(2,2)]))) error stop 'Symmetry33_11-22/hP' @@ -2285,52 +2285,52 @@ subroutine selfTest end do call random_number(C) - C(1,1) = C(1,1) + C(1,2) + 0.1_pReal + C(1,1) = C(1,1) + C(1,2) + 0.1_pREAL C(1,3) = C(1,2) C(3,3) = C(1,1) - C(4,4) = 0.5_pReal * (C(1,1) - C(1,2)) + C(4,4) = 0.5_pREAL * (C(1,1) - C(1,2)) C(6,6) = C(4,4) C_cI = lattice_symmetrize_C66(C,'cI') - if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostrain','cI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/cI' - if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostress','cI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/cI' + if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostrain','cI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/cI' + if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostress','cI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/cI' lambda = C_cI(1,2) - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_cI,'isostrain','cI')), & - lattice_isotropic_nu(C_cI,'isostrain','cI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/cI' - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_cI,'isostress','cI')), & - lattice_isotropic_nu(C_cI,'isostress','cI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/cI' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_cI,'isostrain','cI')), & + lattice_isotropic_nu(C_cI,'isostrain','cI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/cI' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_cI,'isostress','cI')), & + lattice_isotropic_nu(C_cI,'isostress','cI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/cI' C_hP = lattice_symmetrize_C66(C,'hP') - if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostrain','hP'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/hP' - if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostress','hP'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/hP' + if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostrain','hP'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/hP' + if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostress','hP'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/hP' lambda = C_hP(1,2) - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_hP,'isostrain','hP')), & - lattice_isotropic_nu(C_hP,'isostrain','hP'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/hP' - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_hP,'isostress','hP')), & - lattice_isotropic_nu(C_hP,'isostress','hP'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/hP' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_hP,'isostrain','hP')), & + lattice_isotropic_nu(C_hP,'isostrain','hP'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/hP' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_hP,'isostress','hP')), & + lattice_isotropic_nu(C_hP,'isostress','hP'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/hP' C_tI = lattice_symmetrize_C66(C,'tI') - if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostrain','tI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/tI' - if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostress','tI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/tI' + if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostrain','tI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/tI' + if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostress','tI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/tI' lambda = C_tI(1,2) - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_tI,'isostrain','tI')), & - lattice_isotropic_nu(C_tI,'isostrain','tI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/tI' - if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_tI,'isostress','tI')), & - lattice_isotropic_nu(C_tI,'isostress','tI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/tI' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_tI,'isostrain','tI')), & + lattice_isotropic_nu(C_tI,'isostrain','tI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/tI' + if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_tI,'isostress','tI')), & + lattice_isotropic_nu(C_tI,'isostress','tI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/tI' call random_number(C) C = lattice_symmetrize_C66(C+math_eye(6),'cI') - if (dNeq(lattice_isotropic_mu(C,'isostrain','cI'), lattice_isotropic_mu(C,'isostrain','hP'), 1.0e-12_pReal)) & + if (dNeq(lattice_isotropic_mu(C,'isostrain','cI'), lattice_isotropic_mu(C,'isostrain','hP'), 1.0e-12_pREAL)) & error stop 'isotropic_mu/isostrain/cI-hP' - if (dNeq(lattice_isotropic_nu(C,'isostrain','cF'), lattice_isotropic_nu(C,'isostrain','cI'), 1.0e-12_pReal)) & + if (dNeq(lattice_isotropic_nu(C,'isostrain','cF'), lattice_isotropic_nu(C,'isostrain','cI'), 1.0e-12_pREAL)) & error stop 'isotropic_nu/isostrain/cF-tI' - if (dNeq(lattice_isotropic_mu(C,'isostress','cI'), lattice_isotropic_mu(C,'isostress'), 1.0e-12_pReal)) & + if (dNeq(lattice_isotropic_mu(C,'isostress','cI'), lattice_isotropic_mu(C,'isostress'), 1.0e-12_pREAL)) & error stop 'isotropic_mu/isostress/cI-hP' - if (dNeq(lattice_isotropic_nu(C,'isostress','cF'), lattice_isotropic_nu(C,'isostress'), 1.0e-12_pReal)) & + if (dNeq(lattice_isotropic_nu(C,'isostress','cF'), lattice_isotropic_nu(C,'isostress'), 1.0e-12_pREAL)) & error stop 'isotropic_nu/isostress/cF-tI' end subroutine selfTest diff --git a/src/material.f90 b/src/material.f90 index beeda8e42..82345fb1e 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -22,7 +22,7 @@ module material end type tRotationContainer type, public :: tTensorContainer - real(pReal), dimension(:,:,:), allocatable :: data + real(pREAL), dimension(:,:,:), allocatable :: data end type tTensorContainer @@ -45,7 +45,7 @@ module material material_ID_phase, & !< Number of the phase material_entry_phase !< Position in array of used phase - real(pReal), dimension(:,:), allocatable, public, protected :: & + real(pREAL), dimension(:,:), allocatable, public, protected :: & material_v ! fraction public :: & @@ -97,9 +97,9 @@ subroutine parse() counterHomogenization, & ho_of integer, dimension(:,:), allocatable :: ph_of - real(pReal), dimension(:,:), allocatable :: v_of + real(pREAL), dimension(:,:), allocatable :: v_of - real(pReal) :: v + real(pREAL) :: v integer :: & el, ip, & ho, ph, & @@ -125,14 +125,14 @@ subroutine parse() end do homogenization_maxNconstituents = maxval(homogenization_Nconstituents) - allocate(material_v(homogenization_maxNconstituents,discretization_Ncells),source=0.0_pReal) + allocate(material_v(homogenization_maxNconstituents,discretization_Ncells),source=0.0_pREAL) allocate(material_O_0(materials%length)) allocate(material_V_e_0(materials%length)) allocate(ho_of(materials%length)) allocate(ph_of(materials%length,homogenization_maxNconstituents),source=-1) - allocate( v_of(materials%length,homogenization_maxNconstituents),source=0.0_pReal) + allocate( v_of(materials%length,homogenization_maxNconstituents),source=0.0_pREAL) ! Parse YAML structure. Manual loop over linked list to have O(n) instead of O(n^2) complexity item => materials%first @@ -158,7 +158,7 @@ subroutine parse() call IO_error(147) end do - if (dNeq(sum(v_of(ma,:)),1.0_pReal,1.e-9_pReal)) call IO_error(153,ext_msg='constituent') + if (dNeq(sum(v_of(ma,:)),1.0_pREAL,1.e-9_pREAL)) call IO_error(153,ext_msg='constituent') item => item%next end do diff --git a/src/materialpoint.f90 b/src/materialpoint.f90 index dda2e5870..f624a4db3 100644 --- a/src/materialpoint.f90 +++ b/src/materialpoint.f90 @@ -141,7 +141,7 @@ end subroutine materialpoint_forward subroutine materialpoint_result(inc,time) integer, intent(in) :: inc - real(pReal), intent(in) :: time + real(pREAL), intent(in) :: time call result_openJobFile() call result_addIncrement(inc,time) diff --git a/src/math.f90 b/src/math.f90 index 3c1f5b608..4a1ffb707 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -31,24 +31,24 @@ module math config #endif - real(pReal), parameter :: & - PI = acos(-1.0_pReal), & !< ratio of a circle's circumference to its diameter - TAU = 2.0_pReal*PI, & !< ratio of a circle's circumference to its radius - INDEG = 360.0_pReal/TAU, & !< conversion from radian to degree - INRAD = TAU/360.0_pReal !< conversion from degree to radian + real(pREAL), parameter :: & + PI = acos(-1.0_pREAL), & !< ratio of a circle's circumference to its diameter + TAU = 2.0_pREAL*PI, & !< ratio of a circle's circumference to its radius + INDEG = 360.0_pREAL/TAU, & !< conversion from radian to degree + INRAD = TAU/360.0_pREAL !< conversion from degree to radian - real(pReal), dimension(3,3), parameter :: & + real(pREAL), dimension(3,3), parameter :: & math_I3 = reshape([& - 1.0_pReal,0.0_pReal,0.0_pReal, & - 0.0_pReal,1.0_pReal,0.0_pReal, & - 0.0_pReal,0.0_pReal,1.0_pReal & + 1.0_pREAL,0.0_pREAL,0.0_pREAL, & + 0.0_pREAL,1.0_pREAL,0.0_pREAL, & + 0.0_pREAL,0.0_pREAL,1.0_pREAL & ],shape(math_I3)) !< 3x3 Identity - real(pReal), dimension(*), parameter, private :: & - NRMMANDEL = [1.0_pReal, 1.0_pReal,1.0_pReal, sqrt(2.0_pReal), sqrt(2.0_pReal), sqrt(2.0_pReal)] !< forward weighting for Mandel notation + real(pREAL), dimension(*), parameter, private :: & + NRMMANDEL = [1.0_pREAL, 1.0_pREAL,1.0_pREAL, sqrt(2.0_pREAL), sqrt(2.0_pREAL), sqrt(2.0_pREAL)] !< forward weighting for Mandel notation - real(pReal), dimension(*), parameter, private :: & - INVNRMMANDEL = 1.0_pReal/NRMMANDEL !< backward weighting for Mandel notation + real(pREAL), dimension(*), parameter, private :: & + INVNRMMANDEL = 1.0_pREAL/NRMMANDEL !< backward weighting for Mandel notation integer, dimension (2,6), parameter, private :: & MAPNYE = reshape([& @@ -94,7 +94,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine math_init() - real(pReal), dimension(4) :: randTest + real(pREAL), dimension(4) :: randTest integer :: randSize integer, dimension(:), allocatable :: seed type(tDict), pointer :: & @@ -201,9 +201,9 @@ end subroutine math_sort !-------------------------------------------------------------------------------------------------- pure function math_expand(what,how) - real(pReal), dimension(:), intent(in) :: what + real(pREAL), dimension(:), intent(in) :: what integer, dimension(:), intent(in) :: how - real(pReal), dimension(sum(how)) :: math_expand + real(pREAL), dimension(sum(how)) :: math_expand integer :: i @@ -239,14 +239,14 @@ end function math_range pure function math_eye(d) integer, intent(in) :: d !< tensor dimension - real(pReal), dimension(d,d) :: math_eye + real(pREAL), dimension(d,d) :: math_eye integer :: i - math_eye = 0.0_pReal + math_eye = 0.0_pREAL do i=1,d - math_eye(i,i) = 1.0_pReal + math_eye(i,i) = 1.0_pREAL end do end function math_eye @@ -258,18 +258,18 @@ end function math_eye !-------------------------------------------------------------------------------------------------- pure function math_identity4th() - real(pReal), dimension(3,3,3,3) :: math_identity4th + real(pREAL), dimension(3,3,3,3) :: math_identity4th integer :: i,j,k,l #ifndef __INTEL_COMPILER do concurrent(i=1:3, j=1:3, k=1:3, l=1:3) - math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) + math_identity4th(i,j,k,l) = 0.5_pREAL*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) end do #else forall(i=1:3, j=1:3, k=1:3, l=1:3) & - math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) + math_identity4th(i,j,k,l) = 0.5_pREAL*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) #endif end function math_identity4th @@ -281,7 +281,7 @@ end function math_identity4th ! e_ijk = -1 if odd permutation of ijk ! e_ijk = 0 otherwise !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_LeviCivita(i,j,k) +real(pREAL) pure function math_LeviCivita(i,j,k) integer, intent(in) :: i,j,k @@ -289,11 +289,11 @@ real(pReal) pure function math_LeviCivita(i,j,k) if (any([(all(cshift([i,j,k],o) == [1,2,3]),o=0,2)])) then - math_LeviCivita = +1.0_pReal + math_LeviCivita = +1.0_pREAL elseif (any([(all(cshift([i,j,k],o) == [3,2,1]),o=0,2)])) then - math_LeviCivita = -1.0_pReal + math_LeviCivita = -1.0_pREAL else - math_LeviCivita = 0.0_pReal + math_LeviCivita = 0.0_pREAL end if end function math_LeviCivita @@ -304,12 +304,12 @@ end function math_LeviCivita ! d_ij = 1 if i = j ! d_ij = 0 otherwise !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_delta(i,j) +real(pREAL) pure function math_delta(i,j) integer, intent (in) :: i,j - math_delta = merge(0.0_pReal, 1.0_pReal, i /= j) + math_delta = merge(0.0_pREAL, 1.0_pREAL, i /= j) end function math_delta @@ -319,8 +319,8 @@ end function math_delta !-------------------------------------------------------------------------------------------------- pure function math_cross(A,B) - real(pReal), dimension(3), intent(in) :: A,B - real(pReal), dimension(3) :: math_cross + real(pREAL), dimension(3), intent(in) :: A,B + real(pREAL), dimension(3) :: math_cross math_cross = [ A(2)*B(3) -A(3)*B(2), & @@ -335,8 +335,8 @@ end function math_cross !-------------------------------------------------------------------------------------------------- pure function math_outer(A,B) - real(pReal), dimension(:), intent(in) :: A,B - real(pReal), dimension(size(A,1),size(B,1)) :: math_outer + real(pREAL), dimension(:), intent(in) :: A,B + real(pREAL), dimension(size(A,1),size(B,1)) :: math_outer integer :: i,j @@ -355,10 +355,10 @@ end function math_outer !-------------------------------------------------------------------------------------------------- !> @brief inner product of arbitrary sized vectors (A · B / i,i) !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_inner(A,B) +real(pREAL) pure function math_inner(A,B) - real(pReal), dimension(:), intent(in) :: A - real(pReal), dimension(size(A,1)), intent(in) :: B + real(pREAL), dimension(:), intent(in) :: A + real(pREAL), dimension(size(A,1)), intent(in) :: B math_inner = sum(A*B) @@ -369,9 +369,9 @@ end function math_inner !-------------------------------------------------------------------------------------------------- !> @brief double contraction of 3x3 matrices (A : B / ij,ij) !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_tensordot(A,B) +real(pREAL) pure function math_tensordot(A,B) - real(pReal), dimension(3,3), intent(in) :: A,B + real(pREAL), dimension(3,3), intent(in) :: A,B math_tensordot = sum(A*B) @@ -384,9 +384,9 @@ end function math_tensordot !-------------------------------------------------------------------------------------------------- pure function math_mul3333xx33(A,B) - real(pReal), dimension(3,3,3,3), intent(in) :: A - real(pReal), dimension(3,3), intent(in) :: B - real(pReal), dimension(3,3) :: math_mul3333xx33 + real(pREAL), dimension(3,3,3,3), intent(in) :: A + real(pREAL), dimension(3,3), intent(in) :: B + real(pREAL), dimension(3,3) :: math_mul3333xx33 integer :: i,j @@ -407,9 +407,9 @@ end function math_mul3333xx33 !-------------------------------------------------------------------------------------------------- pure function math_mul3333xx3333(A,B) - real(pReal), dimension(3,3,3,3), intent(in) :: A - real(pReal), dimension(3,3,3,3), intent(in) :: B - real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333 + real(pREAL), dimension(3,3,3,3), intent(in) :: A + real(pREAL), dimension(3,3,3,3), intent(in) :: B + real(pREAL), dimension(3,3,3,3) :: math_mul3333xx3333 integer :: i,j,k,l @@ -430,20 +430,20 @@ end function math_mul3333xx3333 !-------------------------------------------------------------------------------------------------- pure function math_exp33(A,n) - real(pReal), dimension(3,3), intent(in) :: A + real(pREAL), dimension(3,3), intent(in) :: A integer, intent(in), optional :: n - real(pReal), dimension(3,3) :: B, math_exp33 + real(pREAL), dimension(3,3) :: B, math_exp33 - real(pReal) :: invFac + real(pREAL) :: invFac integer :: i - invFac = 1.0_pReal ! 0! + invFac = 1.0_pREAL ! 0! B = math_I3 math_exp33 = math_I3 ! A^0 = I do i = 1, misc_optional(n,5) - invFac = invFac/real(i,pReal) ! invfac = 1/(i!) + invFac = invFac/real(i,pREAL) ! invfac = 1/(i!) B = matmul(B,A) math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!) end do @@ -458,15 +458,15 @@ end function math_exp33 !-------------------------------------------------------------------------------------------------- pure function math_inv33(A) - real(pReal), dimension(3,3), intent(in) :: A - real(pReal), dimension(3,3) :: math_inv33 + real(pREAL), dimension(3,3), intent(in) :: A + real(pREAL), dimension(3,3) :: math_inv33 - real(pReal) :: DetA + real(pREAL) :: DetA logical :: error call math_invert33(math_inv33,DetA,error,A) - if (error) math_inv33 = 0.0_pReal + if (error) math_inv33 = 0.0_pREAL end function math_inv33 @@ -478,12 +478,12 @@ end function math_inv33 !-------------------------------------------------------------------------------------------------- pure subroutine math_invert33(InvA,DetA,error, A) - real(pReal), dimension(3,3), intent(out) :: InvA - real(pReal), intent(out), optional :: DetA + real(pREAL), dimension(3,3), intent(out) :: InvA + real(pREAL), intent(out), optional :: DetA logical, intent(out) :: error - real(pReal), dimension(3,3), intent(in) :: A + real(pREAL), dimension(3,3), intent(in) :: A - real(pReal) :: Det + real(pREAL) :: Det InvA(1,1) = A(2,2) * A(3,3) - A(2,3) * A(3,2) @@ -493,8 +493,8 @@ pure subroutine math_invert33(InvA,DetA,error, A) Det = A(1,1) * InvA(1,1) + A(1,2) * InvA(2,1) + A(1,3) * InvA(3,1) if (dEq0(Det)) then - InvA = 0.0_pReal - if (present(DetA)) DetA = 0.0_pReal + InvA = 0.0_pREAL + if (present(DetA)) DetA = 0.0_pREAL error = .true. else InvA(1,2) = -A(1,2) * A(3,3) + A(1,3) * A(3,2) @@ -518,13 +518,13 @@ end subroutine math_invert33 !-------------------------------------------------------------------------------------------------- pure function math_invSym3333(A) - real(pReal),dimension(3,3,3,3) :: math_invSym3333 + real(pREAL),dimension(3,3,3,3) :: math_invSym3333 - real(pReal),dimension(3,3,3,3),intent(in) :: A + real(pREAL),dimension(3,3,3,3),intent(in) :: A integer, dimension(6) :: ipiv6 - real(pReal), dimension(6,6) :: temp66 - real(pReal), dimension(6*6) :: work + real(pREAL), dimension(6,6) :: temp66 + real(pREAL), dimension(6*6) :: work integer :: ierr_i, ierr_f @@ -545,12 +545,12 @@ end function math_invSym3333 !-------------------------------------------------------------------------------------------------- pure subroutine math_invert(InvA, error, A) - real(pReal), dimension(:,:), intent(in) :: A - real(pReal), dimension(size(A,1),size(A,1)), intent(out) :: invA + real(pREAL), dimension(:,:), intent(in) :: A + real(pREAL), dimension(size(A,1),size(A,1)), intent(out) :: invA logical, intent(out) :: error integer, dimension(size(A,1)) :: ipiv - real(pReal), dimension(size(A,1)**2) :: work + real(pREAL), dimension(size(A,1)**2) :: work integer :: ierr @@ -568,11 +568,11 @@ end subroutine math_invert !-------------------------------------------------------------------------------------------------- pure function math_symmetric33(m) - real(pReal), dimension(3,3) :: math_symmetric33 - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3) :: math_symmetric33 + real(pREAL), dimension(3,3), intent(in) :: m - math_symmetric33 = 0.5_pReal * (m + transpose(m)) + math_symmetric33 = 0.5_pREAL * (m + transpose(m)) end function math_symmetric33 @@ -582,8 +582,8 @@ end function math_symmetric33 !-------------------------------------------------------------------------------------------------- pure function math_skew33(m) - real(pReal), dimension(3,3) :: math_skew33 - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3) :: math_skew33 + real(pREAL), dimension(3,3), intent(in) :: m math_skew33 = m - math_symmetric33(m) @@ -596,11 +596,11 @@ end function math_skew33 !-------------------------------------------------------------------------------------------------- pure function math_spherical33(m) - real(pReal), dimension(3,3) :: math_spherical33 - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3) :: math_spherical33 + real(pREAL), dimension(3,3), intent(in) :: m - math_spherical33 = math_I3 * math_trace33(m)/3.0_pReal + math_spherical33 = math_I3 * math_trace33(m)/3.0_pREAL end function math_spherical33 @@ -610,8 +610,8 @@ end function math_spherical33 !-------------------------------------------------------------------------------------------------- pure function math_deviatoric33(m) - real(pReal), dimension(3,3) :: math_deviatoric33 - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3) :: math_deviatoric33 + real(pREAL), dimension(3,3), intent(in) :: m math_deviatoric33 = m - math_spherical33(m) @@ -622,9 +622,9 @@ end function math_deviatoric33 !-------------------------------------------------------------------------------------------------- !> @brief Calculate trace of a 3x3 matrix. !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_trace33(m) +real(pREAL) pure function math_trace33(m) - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3), intent(in) :: m math_trace33 = m(1,1) + m(2,2) + m(3,3) @@ -635,9 +635,9 @@ end function math_trace33 !-------------------------------------------------------------------------------------------------- !> @brief Calculate determinant of a 3x3 matrix. !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_det33(m) +real(pREAL) pure function math_det33(m) - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3), intent(in) :: m math_det33 = m(1,1)* (m(2,2)*m(3,3)-m(2,3)*m(3,2)) & @@ -650,13 +650,13 @@ end function math_det33 !-------------------------------------------------------------------------------------------------- !> @brief Calculate determinant of a symmetric 3x3 matrix. !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_detSym33(m) +real(pREAL) pure function math_detSym33(m) - real(pReal), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3,3), intent(in) :: m math_detSym33 = -(m(1,1)*m(2,3)**2 + m(2,2)*m(1,3)**2 + m(3,3)*m(1,2)**2) & - + m(1,1)*m(2,2)*m(3,3) + 2.0_pReal * m(1,2)*m(1,3)*m(2,3) + + m(1,1)*m(2,2)*m(3,3) + 2.0_pREAL * m(1,2)*m(1,3)*m(2,3) end function math_detSym33 @@ -666,8 +666,8 @@ end function math_detSym33 !-------------------------------------------------------------------------------------------------- pure function math_33to9(m33) - real(pReal), dimension(9) :: math_33to9 - real(pReal), dimension(3,3), intent(in) :: m33 + real(pREAL), dimension(9) :: math_33to9 + real(pREAL), dimension(3,3), intent(in) :: m33 integer :: i @@ -682,8 +682,8 @@ end function math_33to9 !-------------------------------------------------------------------------------------------------- pure function math_9to33(v9) - real(pReal), dimension(3,3) :: math_9to33 - real(pReal), dimension(9), intent(in) :: v9 + real(pREAL), dimension(3,3) :: math_9to33 + real(pREAL), dimension(9), intent(in) :: v9 integer :: i @@ -703,14 +703,14 @@ end function math_9to33 !-------------------------------------------------------------------------------------------------- pure function math_sym33to6(m33,weighted) - real(pReal), dimension(6) :: math_sym33to6 - real(pReal), dimension(3,3), intent(in) :: m33 !< symmetric 3x3 matrix (no internal check) + real(pREAL), dimension(6) :: math_sym33to6 + real(pREAL), dimension(3,3), intent(in) :: m33 !< symmetric 3x3 matrix (no internal check) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) - real(pReal), dimension(6) :: w + real(pREAL), dimension(6) :: w integer :: i - w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) + w = merge(NRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.)) math_sym33to6 = [(w(i)*m33(MAPNYE(1,i),MAPNYE(2,i)),i=1,6)] @@ -725,15 +725,15 @@ end function math_sym33to6 !-------------------------------------------------------------------------------------------------- pure function math_6toSym33(v6,weighted) - real(pReal), dimension(3,3) :: math_6toSym33 - real(pReal), dimension(6), intent(in) :: v6 !< 6 vector + real(pREAL), dimension(3,3) :: math_6toSym33 + real(pREAL), dimension(6), intent(in) :: v6 !< 6 vector logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) - real(pReal), dimension(6) :: w + real(pREAL), dimension(6) :: w integer :: i - w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) + w = merge(INVNRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.)) do i=1,6 math_6toSym33(MAPNYE(1,i),MAPNYE(2,i)) = w(i)*v6(i) @@ -748,8 +748,8 @@ end function math_6toSym33 !-------------------------------------------------------------------------------------------------- pure function math_3333to99(m3333) - real(pReal), dimension(9,9) :: math_3333to99 - real(pReal), dimension(3,3,3,3), intent(in) :: m3333 + real(pREAL), dimension(9,9) :: math_3333to99 + real(pREAL), dimension(3,3,3,3), intent(in) :: m3333 integer :: i,j @@ -770,8 +770,8 @@ end function math_3333to99 !-------------------------------------------------------------------------------------------------- pure function math_99to3333(m99) - real(pReal), dimension(3,3,3,3) :: math_99to3333 - real(pReal), dimension(9,9), intent(in) :: m99 + real(pREAL), dimension(3,3,3,3) :: math_99to3333 + real(pREAL), dimension(9,9), intent(in) :: m99 integer :: i,j @@ -795,15 +795,15 @@ end function math_99to3333 !-------------------------------------------------------------------------------------------------- pure function math_sym3333to66(m3333,weighted) - real(pReal), dimension(6,6) :: math_sym3333to66 - real(pReal), dimension(3,3,3,3), intent(in) :: m3333 !< symmetric 3x3x3x3 matrix (no internal check) + real(pREAL), dimension(6,6) :: math_sym3333to66 + real(pREAL), dimension(3,3,3,3), intent(in) :: m3333 !< symmetric 3x3x3x3 matrix (no internal check) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) - real(pReal), dimension(6) :: w + real(pREAL), dimension(6) :: w integer :: i,j - w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) + w = merge(NRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.)) #ifndef __INTEL_COMPILER do concurrent(i=1:6, j=1:6) @@ -824,15 +824,15 @@ end function math_sym3333to66 !-------------------------------------------------------------------------------------------------- pure function math_66toSym3333(m66,weighted) - real(pReal), dimension(3,3,3,3) :: math_66toSym3333 - real(pReal), dimension(6,6), intent(in) :: m66 !< 6x6 matrix + real(pREAL), dimension(3,3,3,3) :: math_66toSym3333 + real(pREAL), dimension(6,6), intent(in) :: m66 !< 6x6 matrix logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) - real(pReal), dimension(6) :: w + real(pREAL), dimension(6) :: w integer :: i,j - w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) + w = merge(INVNRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.)) do i=1,6; do j=1,6 math_66toSym3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j)) = w(i)*w(j)*m66(i,j) @@ -849,8 +849,8 @@ end function math_66toSym3333 !-------------------------------------------------------------------------------------------------- pure function math_Voigt6to33_stress(sigma_tilde) result(sigma) - real(pReal), dimension(3,3) :: sigma - real(pReal), dimension(6), intent(in) :: sigma_tilde + real(pREAL), dimension(3,3) :: sigma + real(pREAL), dimension(6), intent(in) :: sigma_tilde sigma = reshape([sigma_tilde(1), sigma_tilde(6), sigma_tilde(5), & @@ -865,13 +865,13 @@ end function math_Voigt6to33_stress !-------------------------------------------------------------------------------------------------- pure function math_Voigt6to33_strain(epsilon_tilde) result(epsilon) - real(pReal), dimension(3,3) :: epsilon - real(pReal), dimension(6), intent(in) :: epsilon_tilde + real(pREAL), dimension(3,3) :: epsilon + real(pREAL), dimension(6), intent(in) :: epsilon_tilde - epsilon = reshape([ epsilon_tilde(1), 0.5_pReal*epsilon_tilde(6), 0.5_pReal*epsilon_tilde(5), & - 0.5_pReal*epsilon_tilde(6), epsilon_tilde(2), 0.5_pReal*epsilon_tilde(4), & - 0.5_pReal*epsilon_tilde(5), 0.5_pReal*epsilon_tilde(4), epsilon_tilde(3)],[3,3]) + epsilon = reshape([ epsilon_tilde(1), 0.5_pREAL*epsilon_tilde(6), 0.5_pREAL*epsilon_tilde(5), & + 0.5_pREAL*epsilon_tilde(6), epsilon_tilde(2), 0.5_pREAL*epsilon_tilde(4), & + 0.5_pREAL*epsilon_tilde(5), 0.5_pREAL*epsilon_tilde(4), epsilon_tilde(3)],[3,3]) end function math_Voigt6to33_strain @@ -881,8 +881,8 @@ end function math_Voigt6to33_strain !-------------------------------------------------------------------------------------------------- pure function math_33toVoigt6_stress(sigma) result(sigma_tilde) - real(pReal), dimension(6) :: sigma_tilde - real(pReal), dimension(3,3), intent(in) :: sigma + real(pREAL), dimension(6) :: sigma_tilde + real(pREAL), dimension(3,3), intent(in) :: sigma sigma_tilde = [sigma(1,1), sigma(2,2), sigma(3,3), & @@ -896,12 +896,12 @@ end function math_33toVoigt6_stress !-------------------------------------------------------------------------------------------------- pure function math_33toVoigt6_strain(epsilon) result(epsilon_tilde) - real(pReal), dimension(6) :: epsilon_tilde - real(pReal), dimension(3,3), intent(in) :: epsilon + real(pREAL), dimension(6) :: epsilon_tilde + real(pREAL), dimension(3,3), intent(in) :: epsilon epsilon_tilde = [ epsilon(1,1), epsilon(2,2), epsilon(3,3), & - 2.0_pReal*epsilon(3,2), 2.0_pReal*epsilon(3,1), 2.0_pReal*epsilon(1,2)] + 2.0_pREAL*epsilon(3,2), 2.0_pREAL*epsilon(3,1), 2.0_pREAL*epsilon(1,2)] end function math_33toVoigt6_strain @@ -912,8 +912,8 @@ end function math_33toVoigt6_strain !-------------------------------------------------------------------------------------------------- pure function math_Voigt66to3333_stiffness(C_tilde) result(C) - real(pReal), dimension(3,3,3,3) :: C - real(pReal), dimension(6,6), intent(in) :: C_tilde + real(pREAL), dimension(3,3,3,3) :: C + real(pREAL), dimension(6,6), intent(in) :: C_tilde integer :: i,j @@ -933,8 +933,8 @@ end function math_Voigt66to3333_stiffness !-------------------------------------------------------------------------------------------------- pure function math_3333toVoigt66_stiffness(C) result(C_tilde) - real(pReal), dimension(6,6) :: C_tilde - real(pReal), dimension(3,3,3,3), intent(in) :: C + real(pREAL), dimension(6,6) :: C_tilde + real(pREAL), dimension(3,3,3,3), intent(in) :: C integer :: i,j @@ -957,15 +957,15 @@ end function math_3333toVoigt66_stiffness !-------------------------------------------------------------------------------------------------- impure elemental subroutine math_normal(x,mu,sigma) - real(pReal), intent(out) :: x - real(pReal), intent(in), optional :: mu, sigma + real(pREAL), intent(out) :: x + real(pREAL), intent(in), optional :: mu, sigma - real(pReal), dimension(2) :: rnd + real(pREAL), dimension(2) :: rnd call random_number(rnd) - x = misc_optional(mu,0.0_pReal) & - + misc_optional(sigma,1.0_pReal) * sqrt(-2.0_pReal*log(1.0_pReal-rnd(1)))*cos(TAU*(1.0_pReal - rnd(2))) + x = misc_optional(mu,0.0_pREAL) & + + misc_optional(sigma,1.0_pREAL) * sqrt(-2.0_pREAL*log(1.0_pREAL-rnd(1)))*cos(TAU*(1.0_pREAL - rnd(2))) end subroutine math_normal @@ -975,13 +975,13 @@ end subroutine math_normal !-------------------------------------------------------------------------------------------------- pure subroutine math_eigh(w,v,error,m) - real(pReal), dimension(:,:), intent(in) :: m !< quadratic matrix to compute eigenvectors and values of - real(pReal), dimension(size(m,1)), intent(out) :: w !< eigenvalues - real(pReal), dimension(size(m,1),size(m,1)), intent(out) :: v !< eigenvectors + real(pREAL), dimension(:,:), intent(in) :: m !< quadratic matrix to compute eigenvectors and values of + real(pREAL), dimension(size(m,1)), intent(out) :: w !< eigenvalues + real(pREAL), dimension(size(m,1),size(m,1)), intent(out) :: v !< eigenvectors logical, intent(out) :: error integer :: ierr - real(pReal), dimension(size(m,1)**2) :: work + real(pREAL), dimension(size(m,1)**2) :: work v = m ! copy matrix to input (doubles as output) array @@ -1000,11 +1000,11 @@ end subroutine math_eigh !-------------------------------------------------------------------------------------------------- pure subroutine math_eigh33(w,v,m) - real(pReal), dimension(3,3),intent(in) :: m !< 3x3 matrix to compute eigenvectors and values of - real(pReal), dimension(3), intent(out) :: w !< eigenvalues - real(pReal), dimension(3,3),intent(out) :: v !< eigenvectors + real(pREAL), dimension(3,3),intent(in) :: m !< 3x3 matrix to compute eigenvectors and values of + real(pREAL), dimension(3), intent(out) :: w !< eigenvalues + real(pREAL), dimension(3,3),intent(out) :: v !< eigenvectors - real(pReal) :: T, U, norm, threshold + real(pREAL) :: T, U, norm, threshold logical :: error @@ -1016,7 +1016,7 @@ pure subroutine math_eigh33(w,v,m) T = maxval(abs(w)) U = max(T, T**2) - threshold = sqrt(5.68e-14_pReal * U**2) + threshold = sqrt(5.68e-14_pREAL * U**2) #ifndef __INTEL_LLVM_COMPILER v(1:3,1) = [m(1,3)*w(1) + v(1,2), & @@ -1059,32 +1059,32 @@ end subroutine math_eigh33 !-------------------------------------------------------------------------------------------------- pure function math_rotationalPart(F) result(R) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & F ! deformation gradient - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & C, & ! right Cauchy-Green tensor R ! rotational part - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & lambda, & ! principal stretches I_C, & ! invariants of C I_U ! invariants of U - real(pReal), dimension(2) :: & + real(pREAL), dimension(2) :: & I_F ! first two invariants of F - real(pReal) :: x,Phi + real(pREAL) :: x,Phi C = matmul(transpose(F),F) I_C = math_invariantsSym33(C) - I_F = [math_trace33(F), 0.5_pReal*(math_trace33(F)**2 - math_trace33(matmul(F,F)))] + I_F = [math_trace33(F), 0.5_pREAL*(math_trace33(F)**2 - math_trace33(matmul(F,F)))] - x = math_clip(I_C(1)**2 -3.0_pReal*I_C(2),0.0_pReal)**(3.0_pReal/2.0_pReal) + x = math_clip(I_C(1)**2 -3.0_pREAL*I_C(2),0.0_pREAL)**(3.0_pREAL/2.0_pREAL) if (dNeq0(x)) then - Phi = acos(math_clip((I_C(1)**3 -4.5_pReal*I_C(1)*I_C(2) +13.5_pReal*I_C(3))/x,-1.0_pReal,1.0_pReal)) - lambda = I_C(1) +(2.0_pReal * sqrt(math_clip(I_C(1)**2-3.0_pReal*I_C(2),0.0_pReal))) & - *cos((Phi-TAU*[1.0_pReal,2.0_pReal,3.0_pReal])/3.0_pReal) - lambda = sqrt(math_clip(lambda,0.0_pReal)/3.0_pReal) + Phi = acos(math_clip((I_C(1)**3 -4.5_pREAL*I_C(1)*I_C(2) +13.5_pREAL*I_C(3))/x,-1.0_pREAL,1.0_pREAL)) + lambda = I_C(1) +(2.0_pREAL * sqrt(math_clip(I_C(1)**2-3.0_pREAL*I_C(2),0.0_pREAL))) & + *cos((Phi-TAU*[1.0_pREAL,2.0_pREAL,3.0_pREAL])/3.0_pREAL) + lambda = sqrt(math_clip(lambda,0.0_pREAL)/3.0_pREAL) else - lambda = sqrt(I_C(1)/3.0_pReal) + lambda = sqrt(I_C(1)/3.0_pREAL) end if I_U = [sum(lambda), lambda(1)*lambda(2)+lambda(2)*lambda(3)+lambda(3)*lambda(1), product(lambda)] @@ -1094,7 +1094,7 @@ pure function math_rotationalPart(F) result(R) - I_U(1)*I_F(1) * transpose(F) & + I_U(1) * transpose(matmul(F,F)) & - matmul(F,C) - R = R*math_det33(R)**(-1.0_pReal/3.0_pReal) + R = R*math_det33(R)**(-1.0_pREAL/3.0_pREAL) end function math_rotationalPart @@ -1105,17 +1105,17 @@ end function math_rotationalPart !-------------------------------------------------------------------------------------------------- pure function math_eigvalsh(m) - real(pReal), dimension(:,:), intent(in) :: m !< symmetric matrix to compute eigenvalues of - real(pReal), dimension(size(m,1)) :: math_eigvalsh + real(pREAL), dimension(:,:), intent(in) :: m !< symmetric matrix to compute eigenvalues of + real(pREAL), dimension(size(m,1)) :: math_eigvalsh - real(pReal), dimension(size(m,1),size(m,1)) :: m_ + real(pREAL), dimension(size(m,1),size(m,1)) :: m_ integer :: ierr - real(pReal), dimension(size(m,1)**2) :: work + real(pREAL), dimension(size(m,1)**2) :: work m_ = m ! m_ will be destroyed call dsyev('N','U',size(m,1),m_,size(m,1),math_eigvalsh,work,size(work),ierr) - if (ierr /= 0) math_eigvalsh = IEEE_value(1.0_pReal,IEEE_quiet_NaN) + if (ierr /= 0) math_eigvalsh = IEEE_value(1.0_pREAL,IEEE_quiet_NaN) end function math_eigvalsh @@ -1129,30 +1129,30 @@ end function math_eigvalsh !-------------------------------------------------------------------------------------------------- pure function math_eigvalsh33(m) - real(pReal), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of - real(pReal), dimension(3) :: math_eigvalsh33,I - real(pReal) :: P, Q, rho, phi - real(pReal), parameter :: TOL=1.e-14_pReal + real(pREAL), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of + real(pREAL), dimension(3) :: math_eigvalsh33,I + real(pREAL) :: P, Q, rho, phi + real(pREAL), parameter :: TOL=1.e-14_pREAL I = math_invariantsSym33(m) ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206 - P = I(2)-I(1)**2/3.0_pReal ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) - Q = product(I(1:2))/3.0_pReal & - - 2.0_pReal/27.0_pReal*I(1)**3 & + P = I(2)-I(1)**2/3.0_pREAL ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) + Q = product(I(1:2))/3.0_pREAL & + - 2.0_pREAL/27.0_pREAL*I(1)**3 & - I(3) ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) if (all(abs([P,Q]) < TOL)) then math_eigvalsh33 = math_eigvalsh(m) else - rho=sqrt(-3.0_pReal*P**3)/9.0_pReal - phi=acos(math_clip(-Q/rho*0.5_pReal,-1.0_pReal,1.0_pReal)) - math_eigvalsh33 = 2.0_pReal*rho**(1.0_pReal/3.0_pReal)* & - [cos( phi /3.0_pReal), & - cos((phi+TAU)/3.0_pReal), & - cos((phi+2.0_pReal*TAU)/3.0_pReal) & + rho=sqrt(-3.0_pREAL*P**3)/9.0_pREAL + phi=acos(math_clip(-Q/rho*0.5_pREAL,-1.0_pREAL,1.0_pREAL)) + math_eigvalsh33 = 2.0_pREAL*rho**(1.0_pREAL/3.0_pREAL)* & + [cos( phi /3.0_pREAL), & + cos((phi+TAU)/3.0_pREAL), & + cos((phi+2.0_pREAL*TAU)/3.0_pREAL) & ] & - + I(1)/3.0_pReal + + I(1)/3.0_pREAL end if end function math_eigvalsh33 @@ -1163,8 +1163,8 @@ end function math_eigvalsh33 !-------------------------------------------------------------------------------------------------- pure function math_invariantsSym33(m) - real(pReal), dimension(3,3), intent(in) :: m - real(pReal), dimension(3) :: math_invariantsSym33 + real(pREAL), dimension(3,3), intent(in) :: m + real(pREAL), dimension(3) :: math_invariantsSym33 math_invariantsSym33(1) = math_trace33(m) @@ -1225,17 +1225,17 @@ end function math_multinomial !-------------------------------------------------------------------------------------------------- !> @brief volume of tetrahedron given by four vertices !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_volTetrahedron(v1,v2,v3,v4) +real(pREAL) pure function math_volTetrahedron(v1,v2,v3,v4) - real(pReal), dimension (3), intent(in) :: v1,v2,v3,v4 - real(pReal), dimension (3,3) :: m + real(pREAL), dimension (3), intent(in) :: v1,v2,v3,v4 + real(pREAL), dimension (3,3) :: m m(1:3,1) = v1-v2 m(1:3,2) = v1-v3 m(1:3,3) = v1-v4 - math_volTetrahedron = abs(math_det33(m))/6.0_pReal + math_volTetrahedron = abs(math_det33(m))/6.0_pREAL end function math_volTetrahedron @@ -1243,12 +1243,12 @@ end function math_volTetrahedron !-------------------------------------------------------------------------------------------------- !> @brief area of triangle given by three vertices !-------------------------------------------------------------------------------------------------- -real(pReal) pure function math_areaTriangle(v1,v2,v3) +real(pREAL) pure function math_areaTriangle(v1,v2,v3) - real(pReal), dimension (3), intent(in) :: v1,v2,v3 + real(pREAL), dimension (3), intent(in) :: v1,v2,v3 - math_areaTriangle = 0.5_pReal * norm2(math_cross(v1-v2,v1-v3)) + math_areaTriangle = 0.5_pREAL * norm2(math_cross(v1-v2,v1-v3)) end function math_areaTriangle @@ -1256,10 +1256,10 @@ end function math_areaTriangle !-------------------------------------------------------------------------------------------------- !> @brief Limit a scalar value to a certain range (either one or two sided). !-------------------------------------------------------------------------------------------------- -real(pReal) pure elemental function math_clip(a, left, right) +real(pREAL) pure elemental function math_clip(a, left, right) - real(pReal), intent(in) :: a - real(pReal), intent(in), optional :: left, right + real(pREAL), intent(in) :: a + real(pREAL), intent(in), optional :: left, right math_clip = a @@ -1285,30 +1285,30 @@ subroutine selfTest() integer, dimension(5) :: range_out_ = [1,2,3,4,5] integer, dimension(3) :: ijk - real(pReal) :: det - real(pReal), dimension(3) :: v3_1,v3_2,v3_3,v3_4 - real(pReal), dimension(6) :: v6 - real(pReal), dimension(9) :: v9 - real(pReal), dimension(3,3) :: t33,t33_2 - real(pReal), dimension(6,6) :: t66 - real(pReal), dimension(9,9) :: t99,t99_2 - real(pReal), dimension(:,:), & + real(pREAL) :: det + real(pREAL), dimension(3) :: v3_1,v3_2,v3_3,v3_4 + real(pREAL), dimension(6) :: v6 + real(pREAL), dimension(9) :: v9 + real(pREAL), dimension(3,3) :: t33,t33_2 + real(pREAL), dimension(6,6) :: t66 + real(pREAL), dimension(9,9) :: t99,t99_2 + real(pREAL), dimension(:,:), & allocatable :: txx,txx_2 - real(pReal) :: r + real(pREAL) :: r integer :: d logical :: e - if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,3.0_pReal,3.0_pReal,3.0_pReal] - & - math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2,3,0])) > tol_math_check)) & + if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL,3.0_pREAL,3.0_pREAL,3.0_pREAL] - & + math_expand([1.0_pREAL,2.0_pREAL,3.0_pREAL],[1,2,3,0])) > tol_math_check)) & error stop 'math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]' - if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal] - & - math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2])) > tol_math_check)) & + if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL] - & + math_expand([1.0_pREAL,2.0_pREAL,3.0_pREAL],[1,2])) > tol_math_check)) & error stop 'math_expand [1,2,3] by [1,2] => [1,2,2]' - if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,1.0_pReal,1.0_pReal,1.0_pReal] - & - math_expand([1.0_pReal,2.0_pReal],[1,2,3])) > tol_math_check)) & + if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL,1.0_pREAL,1.0_pREAL,1.0_pREAL] - & + math_expand([1.0_pREAL,2.0_pREAL],[1,2,3])) > tol_math_check)) & error stop 'math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]' call math_sort(sort_in_,1,3,2) @@ -1320,7 +1320,7 @@ subroutine selfTest() if (any(dNeq(math_exp33(math_I3,0),math_I3))) & error stop 'math_exp33(math_I3,1)' - if (any(dNeq(math_exp33(math_I3,128),exp(1.0_pReal)*math_I3))) & + if (any(dNeq(math_exp33(math_I3,128),exp(1.0_pREAL)*math_I3))) & error stop 'math_exp33(math_I3,128)' call random_number(v9) @@ -1336,10 +1336,10 @@ subroutine selfTest() error stop 'math_sym33to6/math_6toSym33' call random_number(t66) - if (any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66,1.0e-15_pReal))) & + if (any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66,1.0e-15_pREAL))) & error stop 'math_sym3333to66/math_66toSym3333' - if (any(dNeq(math_3333toVoigt66_stiffness(math_Voigt66to3333_stiffness(t66)),t66,1.0e-15_pReal))) & + if (any(dNeq(math_3333toVoigt66_stiffness(math_Voigt66to3333_stiffness(t66)),t66,1.0e-15_pREAL))) & error stop 'math_3333toVoigt66/math_Voigt66to3333' call random_number(v6) @@ -1351,12 +1351,12 @@ subroutine selfTest() call random_number(v3_3) call random_number(v3_4) - if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pReal, & - math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pReal)) & + if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pREAL, & + math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pREAL)) & error stop 'math_volTetrahedron' call random_number(t33) - if (dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pReal)) & + if (dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pREAL)) & error stop 'math_det33/math_detSym33' if (any(dNeq(t33+transpose(t33),math_mul3333xx33(math_identity4th(),t33+transpose(t33))))) & @@ -1365,34 +1365,34 @@ subroutine selfTest() if (any(dNeq0(math_eye(3),math_inv33(math_I3)))) & error stop 'math_inv33(math_I3)' - do while(abs(math_det33(t33))<1.0e-9_pReal) + do while(abs(math_det33(t33))<1.0e-9_pREAL) call random_number(t33) end do - if (any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-8_pReal))) & + if (any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-8_pREAL))) & error stop 'math_inv33' call math_invert33(t33_2,det,e,t33) - if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & + if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pREAL)) .or. e) & error stop 'math_invert33: T:T^-1 != I' - if (dNeq(det,math_det33(t33),tol=1.0e-12_pReal)) & + if (dNeq(det,math_det33(t33),tol=1.0e-12_pREAL)) & error stop 'math_invert33 (determinant)' call math_invert(t33_2,e,t33) - if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & + if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pREAL)) .or. e) & error stop 'math_invert t33' - do while(math_det33(t33)<1.0e-2_pReal) ! O(det(F)) = 1 + do while(math_det33(t33)<1.0e-2_pREAL) ! O(det(F)) = 1 call random_number(t33) end do t33_2 = math_rotationalPart(transpose(t33)) t33 = math_rotationalPart(t33) - if (any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pReal))) & + if (any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pREAL))) & error stop 'math_rotationalPart (forward-backward)' - if (dNeq(1.0_pReal,math_det33(math_rotationalPart(t33)),tol=1.0e-10_pReal)) & + if (dNeq(1.0_pREAL,math_det33(math_rotationalPart(t33)),tol=1.0e-10_pREAL)) & error stop 'math_rotationalPart (determinant)' call random_number(r) - d = int(r*5.0_pReal) + 1 + d = int(r*5.0_pREAL) + 1 txx = math_eye(d) allocate(txx_2(d,d)) call math_invert(txx_2,e,txx) @@ -1400,10 +1400,10 @@ subroutine selfTest() error stop 'math_invert(txx)/math_eye' call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix - if (any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pReal)) .or. e) & + if (any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pREAL)) .or. e) & error stop 'math_invert(t99)' - if (any(dNeq(math_clip([4.0_pReal,9.0_pReal],5.0_pReal,6.5_pReal),[5.0_pReal,6.5_pReal]))) & + if (any(dNeq(math_clip([4.0_pREAL,9.0_pREAL],5.0_pREAL,6.5_pREAL),[5.0_pREAL,6.5_pREAL]))) & error stop 'math_clip' if (math_factorial(10) /= 3628800) & @@ -1415,35 +1415,35 @@ subroutine selfTest() if (math_multinomial([1,2,3,4]) /= 12600) & error stop 'math_multinomial' - ijk = cshift([1,2,3],int(r*1.0e2_pReal)) - if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pReal)) & + ijk = cshift([1,2,3],int(r*1.0e2_pREAL)) + if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pREAL)) & error stop 'math_LeviCivita(even)' - ijk = cshift([3,2,1],int(r*2.0e2_pReal)) - if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pReal)) & + ijk = cshift([3,2,1],int(r*2.0e2_pREAL)) + if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pREAL)) & error stop 'math_LeviCivita(odd)' - ijk = cshift([2,2,1],int(r*2.0e2_pReal)) + ijk = cshift([2,2,1],int(r*2.0e2_pREAL)) if (dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3)))) & error stop 'math_LeviCivita' normal_distribution: block integer, parameter :: N = 1000000 - real(pReal), dimension(:), allocatable :: r - real(pReal) :: mu, sigma + real(pREAL), dimension(:), allocatable :: r + real(pREAL) :: mu, sigma allocate(r(N)) call random_number(mu) call random_number(sigma) - sigma = 1.0_pReal + sigma*5.0_pReal - mu = (mu-0.5_pReal)*10_pReal + sigma = 1.0_pREAL + sigma*5.0_pREAL + mu = (mu-0.5_pREAL)*10_pREAL call math_normal(r,mu,sigma) - if (abs(mu -sum(r)/real(N,pReal))>5.0e-2_pReal) & + if (abs(mu -sum(r)/real(N,pREAL))>5.0e-2_pREAL) & error stop 'math_normal(mu)' - mu = sum(r)/real(N,pReal) - if (abs(sigma**2 -1.0_pReal/real(N-1,pReal) * sum((r-mu)**2))/sigma > 5.0e-2_pReal) & + mu = sum(r)/real(N,pREAL) + if (abs(sigma**2 -1.0_pREAL/real(N-1,pREAL) * sum((r-mu)**2))/sigma > 5.0e-2_pREAL) & error stop 'math_normal(sigma)' end block normal_distribution diff --git a/src/mesh/DAMASK_mesh.f90 b/src/mesh/DAMASK_mesh.f90 index 1294edd99..4da6ff94c 100644 --- a/src/mesh/DAMASK_mesh.f90 +++ b/src/mesh/DAMASK_mesh.f90 @@ -23,7 +23,7 @@ program DAMASK_mesh implicit none(type,external) type :: tLoadCase - real(pReal) :: time = 0.0_pReal !< length of increment + real(pREAL) :: time = 0.0_pREAL !< length of increment integer :: incs = 0, & !< number of increments outputfrequency = 1 !< frequency of result writes logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase @@ -43,12 +43,12 @@ program DAMASK_mesh ! loop variables, convergence etc. integer, parameter :: & subStepFactor = 2 !< for each substep, divide the last time increment by 2.0 - real(pReal) :: & - time = 0.0_pReal, & !< elapsed time - time0 = 0.0_pReal, & !< begin of interval - timeinc = 0.0_pReal, & !< current time interval - timeIncOld = 0.0_pReal, & !< previous time interval - remainingLoadCaseTime = 0.0_pReal !< remaining time of current load case + real(pREAL) :: & + time = 0.0_pREAL, & !< elapsed time + time0 = 0.0_pREAL, & !< begin of interval + timeinc = 0.0_pREAL, & !< current time interval + timeIncOld = 0.0_pREAL, & !< previous time interval + remainingLoadCaseTime = 0.0_pREAL !< remaining time of current load case logical :: & guess, & !< guess along former trajectory stagIterate @@ -140,7 +140,7 @@ program DAMASK_mesh end select end do do component = 1, loadCases(i)%fieldBC(1)%nComponents - allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pReal) + allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pREAL) allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Mask (mesh_Nboundaries), source = .false.) end do end do @@ -240,7 +240,7 @@ program DAMASK_mesh print'(/,1x,a)', '... writing initial configuration to file .................................' flush(IO_STDOUT) - call materialpoint_result(0,0.0_pReal) + call materialpoint_result(0,0.0_pREAL) loadCaseLooping: do currentLoadCase = 1, size(loadCases) time0 = time ! load case start time @@ -252,8 +252,8 @@ program DAMASK_mesh !-------------------------------------------------------------------------------------------------- ! forwarding time timeIncOld = timeinc ! last timeinc that brought former inc to an end - timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pReal) - timeinc = timeinc * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step + timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pREAL) + timeinc = timeinc * real(subStepFactor,pREAL)**real(-cutBackLevel,pREAL) ! depending on cut back level, decrease time step stepFraction = 0 ! fraction scaled by stepFactor**cutLevel subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel) @@ -298,7 +298,7 @@ program DAMASK_mesh stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator cutBackLevel = cutBackLevel + 1 time = time - timeinc ! rewind time - timeinc = timeinc/2.0_pReal + timeinc = timeinc/2.0_pREAL print'(/,1x,a)', 'cutting back' else ! default behavior, exit if spectral solver does not converge if (worldrank == 0) close(statUnit) diff --git a/src/mesh/FEM_quadrature.f90 b/src/mesh/FEM_quadrature.f90 index c54f998fa..891e0be0d 100644 --- a/src/mesh/FEM_quadrature.f90 +++ b/src/mesh/FEM_quadrature.f90 @@ -10,18 +10,18 @@ module FEM_quadrature integer, parameter :: & maxOrder = 5 !< maximum integration order - real(pReal), dimension(2,3), parameter :: & - triangle = reshape([-1.0_pReal, -1.0_pReal, & - 1.0_pReal, -1.0_pReal, & - -1.0_pReal, 1.0_pReal], shape=[2,3]) - real(pReal), dimension(3,4), parameter :: & - tetrahedron = reshape([-1.0_pReal, -1.0_pReal, -1.0_pReal, & - 1.0_pReal, -1.0_pReal, -1.0_pReal, & - -1.0_pReal, 1.0_pReal, -1.0_pReal, & - -1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) + real(pREAL), dimension(2,3), parameter :: & + triangle = reshape([-1.0_pREAL, -1.0_pREAL, & + 1.0_pREAL, -1.0_pREAL, & + -1.0_pREAL, 1.0_pREAL], shape=[2,3]) + real(pREAL), dimension(3,4), parameter :: & + tetrahedron = reshape([-1.0_pREAL, -1.0_pREAL, -1.0_pREAL, & + 1.0_pREAL, -1.0_pREAL, -1.0_pREAL, & + -1.0_pREAL, 1.0_pREAL, -1.0_pREAL, & + -1.0_pREAL, -1.0_pREAL, 1.0_pREAL], shape=[3,4]) type :: group_real !< variable length datatype - real(pReal), dimension(:), allocatable :: p + real(pREAL), dimension(:), allocatable :: p end type group_real integer, dimension(2:3,maxOrder), public, protected :: & @@ -51,132 +51,132 @@ subroutine FEM_quadrature_init() FEM_nQuadrature(2,1) = 1 allocate(FEM_quadrature_weights(2,1)%p(FEM_nQuadrature(2,1))) - FEM_quadrature_weights(2,1)%p(1) = 1._pReal + FEM_quadrature_weights(2,1)%p(1) = 1._pREAL - FEM_quadrature_points (2,1)%p = permutationStar3([1._pReal/3._pReal]) + FEM_quadrature_points (2,1)%p = permutationStar3([1._pREAL/3._pREAL]) !-------------------------------------------------------------------------------------------------- ! 2D quadratic FEM_nQuadrature(2,2) = 3 allocate(FEM_quadrature_weights(2,2)%p(FEM_nQuadrature(2,2))) - FEM_quadrature_weights(2,2)%p(1:3) = 1._pReal/3._pReal + FEM_quadrature_weights(2,2)%p(1:3) = 1._pREAL/3._pREAL - FEM_quadrature_points (2,2)%p = permutationStar21([1._pReal/6._pReal]) + FEM_quadrature_points (2,2)%p = permutationStar21([1._pREAL/6._pREAL]) !-------------------------------------------------------------------------------------------------- ! 2D cubic FEM_nQuadrature(2,3) = 6 allocate(FEM_quadrature_weights(2,3)%p(FEM_nQuadrature(2,3))) - FEM_quadrature_weights(2,3)%p(1:3) = 2.2338158967801147e-1_pReal - FEM_quadrature_weights(2,3)%p(4:6) = 1.0995174365532187e-1_pReal + FEM_quadrature_weights(2,3)%p(1:3) = 2.2338158967801147e-1_pREAL + FEM_quadrature_weights(2,3)%p(4:6) = 1.0995174365532187e-1_pREAL FEM_quadrature_points (2,3)%p = [ & - permutationStar21([4.4594849091596489e-1_pReal]), & - permutationStar21([9.157621350977074e-2_pReal]) ] + permutationStar21([4.4594849091596489e-1_pREAL]), & + permutationStar21([9.157621350977074e-2_pREAL]) ] !-------------------------------------------------------------------------------------------------- ! 2D quartic FEM_nQuadrature(2,4) = 12 allocate(FEM_quadrature_weights(2,4)%p(FEM_nQuadrature(2,4))) - FEM_quadrature_weights(2,4)%p(1:3) = 1.1678627572637937e-1_pReal - FEM_quadrature_weights(2,4)%p(4:6) = 5.0844906370206817e-2_pReal - FEM_quadrature_weights(2,4)%p(7:12) = 8.285107561837358e-2_pReal + FEM_quadrature_weights(2,4)%p(1:3) = 1.1678627572637937e-1_pREAL + FEM_quadrature_weights(2,4)%p(4:6) = 5.0844906370206817e-2_pREAL + FEM_quadrature_weights(2,4)%p(7:12) = 8.285107561837358e-2_pREAL FEM_quadrature_points (2,4)%p = [ & - permutationStar21([2.4928674517091042e-1_pReal]), & - permutationStar21([6.308901449150223e-2_pReal]), & - permutationStar111([3.1035245103378440e-1_pReal, 5.3145049844816947e-2_pReal]) ] + permutationStar21([2.4928674517091042e-1_pREAL]), & + permutationStar21([6.308901449150223e-2_pREAL]), & + permutationStar111([3.1035245103378440e-1_pREAL, 5.3145049844816947e-2_pREAL]) ] !-------------------------------------------------------------------------------------------------- ! 2D quintic FEM_nQuadrature(2,5) = 16 allocate(FEM_quadrature_weights(2,5)%p(FEM_nQuadrature(2,5))) - FEM_quadrature_weights(2,5)%p(1:1) = 1.4431560767778717e-1_pReal - FEM_quadrature_weights(2,5)%p(2:4) = 9.509163426728463e-2_pReal - FEM_quadrature_weights(2,5)%p(5:7) = 1.0321737053471825e-1_pReal - FEM_quadrature_weights(2,5)%p(8:10) = 3.2458497623198080e-2_pReal - FEM_quadrature_weights(2,5)%p(11:16) = 2.7230314174434994e-2_pReal + FEM_quadrature_weights(2,5)%p(1:1) = 1.4431560767778717e-1_pREAL + FEM_quadrature_weights(2,5)%p(2:4) = 9.509163426728463e-2_pREAL + FEM_quadrature_weights(2,5)%p(5:7) = 1.0321737053471825e-1_pREAL + FEM_quadrature_weights(2,5)%p(8:10) = 3.2458497623198080e-2_pREAL + FEM_quadrature_weights(2,5)%p(11:16) = 2.7230314174434994e-2_pREAL FEM_quadrature_points (2,5)%p = [ & - permutationStar3([1._pReal/3._pReal]), & - permutationStar21([4.5929258829272316e-1_pReal]), & - permutationStar21([1.705693077517602e-1_pReal]), & - permutationStar21([5.0547228317030975e-2_pReal]), & - permutationStar111([2.631128296346381e-1_pReal, 8.3947774099576053e-2_pReal]) ] + permutationStar3([1._pREAL/3._pREAL]), & + permutationStar21([4.5929258829272316e-1_pREAL]), & + permutationStar21([1.705693077517602e-1_pREAL]), & + permutationStar21([5.0547228317030975e-2_pREAL]), & + permutationStar111([2.631128296346381e-1_pREAL, 8.3947774099576053e-2_pREAL]) ] !-------------------------------------------------------------------------------------------------- ! 3D linear FEM_nQuadrature(3,1) = 1 allocate(FEM_quadrature_weights(3,1)%p(FEM_nQuadrature(3,1))) - FEM_quadrature_weights(3,1)%p(1) = 1.0_pReal + FEM_quadrature_weights(3,1)%p(1) = 1.0_pREAL - FEM_quadrature_points (3,1)%p = permutationStar4([0.25_pReal]) + FEM_quadrature_points (3,1)%p = permutationStar4([0.25_pREAL]) !-------------------------------------------------------------------------------------------------- ! 3D quadratic FEM_nQuadrature(3,2) = 4 allocate(FEM_quadrature_weights(3,2)%p(FEM_nQuadrature(3,2))) - FEM_quadrature_weights(3,2)%p(1:4) = 0.25_pReal + FEM_quadrature_weights(3,2)%p(1:4) = 0.25_pREAL - FEM_quadrature_points (3,2)%p = permutationStar31([1.3819660112501052e-1_pReal]) + FEM_quadrature_points (3,2)%p = permutationStar31([1.3819660112501052e-1_pREAL]) !-------------------------------------------------------------------------------------------------- ! 3D cubic FEM_nQuadrature(3,3) = 14 allocate(FEM_quadrature_weights(3,3)%p(FEM_nQuadrature(3,3))) - FEM_quadrature_weights(3,3)%p(1:4) = 7.3493043116361949e-2_pReal - FEM_quadrature_weights(3,3)%p(5:8) = 1.1268792571801585e-1_pReal - FEM_quadrature_weights(3,3)%p(9:14) = 4.2546020777081467e-2_pReal + FEM_quadrature_weights(3,3)%p(1:4) = 7.3493043116361949e-2_pREAL + FEM_quadrature_weights(3,3)%p(5:8) = 1.1268792571801585e-1_pREAL + FEM_quadrature_weights(3,3)%p(9:14) = 4.2546020777081467e-2_pREAL FEM_quadrature_points (3,3)%p = [ & - permutationStar31([9.273525031089123e-2_pReal]), & - permutationStar31([3.108859192633006e-1_pReal]), & - permutationStar22([4.5503704125649649e-2_pReal]) ] + permutationStar31([9.273525031089123e-2_pREAL]), & + permutationStar31([3.108859192633006e-1_pREAL]), & + permutationStar22([4.5503704125649649e-2_pREAL]) ] !-------------------------------------------------------------------------------------------------- ! 3D quartic (lower precision/unknown source) FEM_nQuadrature(3,4) = 35 allocate(FEM_quadrature_weights(3,4)%p(FEM_nQuadrature(3,4))) - FEM_quadrature_weights(3,4)%p(1:4) = 0.0021900463965388_pReal - FEM_quadrature_weights(3,4)%p(5:16) = 0.0143395670177665_pReal - FEM_quadrature_weights(3,4)%p(17:22) = 0.0250305395686746_pReal - FEM_quadrature_weights(3,4)%p(23:34) = 0.0479839333057554_pReal - FEM_quadrature_weights(3,4)%p(35) = 0.0931745731195340_pReal + FEM_quadrature_weights(3,4)%p(1:4) = 0.0021900463965388_pREAL + FEM_quadrature_weights(3,4)%p(5:16) = 0.0143395670177665_pREAL + FEM_quadrature_weights(3,4)%p(17:22) = 0.0250305395686746_pREAL + FEM_quadrature_weights(3,4)%p(23:34) = 0.0479839333057554_pREAL + FEM_quadrature_weights(3,4)%p(35) = 0.0931745731195340_pREAL FEM_quadrature_points (3,4)%p = [ & - permutationStar31([0.0267367755543735_pReal]), & - permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal]), & - permutationStar22([0.4547545999844830_pReal]), & - permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal]), & - permutationStar4([0.25_pReal]) ] + permutationStar31([0.0267367755543735_pREAL]), & + permutationStar211([0.0391022406356488_pREAL, 0.7477598884818090_pREAL]), & + permutationStar22([0.4547545999844830_pREAL]), & + permutationStar211([0.2232010379623150_pREAL, 0.0504792790607720_pREAL]), & + permutationStar4([0.25_pREAL]) ] !-------------------------------------------------------------------------------------------------- ! 3D quintic (lower precision/unknown source) FEM_nQuadrature(3,5) = 56 allocate(FEM_quadrature_weights(3,5)%p(FEM_nQuadrature(3,5))) - FEM_quadrature_weights(3,5)%p(1:4) = 0.0010373112336140_pReal - FEM_quadrature_weights(3,5)%p(5:16) = 0.0096016645399480_pReal - FEM_quadrature_weights(3,5)%p(17:28) = 0.0164493976798232_pReal - FEM_quadrature_weights(3,5)%p(29:40) = 0.0153747766513310_pReal - FEM_quadrature_weights(3,5)%p(41:52) = 0.0293520118375230_pReal - FEM_quadrature_weights(3,5)%p(53:56) = 0.0366291366405108_pReal + FEM_quadrature_weights(3,5)%p(1:4) = 0.0010373112336140_pREAL + FEM_quadrature_weights(3,5)%p(5:16) = 0.0096016645399480_pREAL + FEM_quadrature_weights(3,5)%p(17:28) = 0.0164493976798232_pREAL + FEM_quadrature_weights(3,5)%p(29:40) = 0.0153747766513310_pREAL + FEM_quadrature_weights(3,5)%p(41:52) = 0.0293520118375230_pREAL + FEM_quadrature_weights(3,5)%p(53:56) = 0.0366291366405108_pREAL FEM_quadrature_points (3,5)%p = [ & - permutationStar31([0.0149520651530592_pReal]), & - permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal]), & - permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal]), & - permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal]), & - permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal]), & - permutationStar31([0.1344783347929940_pReal]) ] + permutationStar31([0.0149520651530592_pREAL]), & + permutationStar211([0.0340960211962615_pREAL, 0.1518319491659370_pREAL]), & + permutationStar211([0.0462051504150017_pREAL, 0.3549340560639790_pREAL]), & + permutationStar211([0.2281904610687610_pREAL, 0.0055147549744775_pREAL]), & + permutationStar211([0.3523052600879940_pREAL, 0.0992057202494530_pREAL]), & + permutationStar31([0.1344783347929940_pREAL]) ] call selfTest() @@ -188,8 +188,8 @@ end subroutine FEM_quadrature_init !-------------------------------------------------------------------------------------------------- pure function permutationStar3(point) result(qPt) - real(pReal), dimension(2) :: qPt - real(pReal), dimension(1), intent(in) :: point + real(pREAL), dimension(2) :: qPt + real(pREAL), dimension(1), intent(in) :: point qPt = pack(matmul(triangle,reshape([ & @@ -203,14 +203,14 @@ end function permutationStar3 !-------------------------------------------------------------------------------------------------- pure function permutationStar21(point) result(qPt) - real(pReal), dimension(6) :: qPt - real(pReal), dimension(1), intent(in) :: point + real(pREAL), dimension(6) :: qPt + real(pREAL), dimension(1), intent(in) :: point qPt = pack(matmul(triangle,reshape([ & - point(1), point(1), 1.0_pReal - 2.0_pReal*point(1), & - point(1), 1.0_pReal - 2.0_pReal*point(1), point(1), & - 1.0_pReal - 2.0_pReal*point(1), point(1), point(1)],[3,3])),.true.) + point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1), & + point(1), 1.0_pREAL - 2.0_pREAL*point(1), point(1), & + 1.0_pREAL - 2.0_pREAL*point(1), point(1), point(1)],[3,3])),.true.) end function permutationStar21 @@ -220,17 +220,17 @@ end function permutationStar21 !-------------------------------------------------------------------------------------------------- pure function permutationStar111(point) result(qPt) - real(pReal), dimension(12) :: qPt - real(pReal), dimension(2), intent(in) :: point + real(pREAL), dimension(12) :: qPt + real(pREAL), dimension(2), intent(in) :: point qPt = pack(matmul(triangle,reshape([ & - point(1), point(2), 1.0_pReal - point(1) - point(2), & - point(1), 1.0_pReal - point(1) - point(2), point(2), & - point(2), point(1), 1.0_pReal - point(1) - point(2), & - point(2), 1.0_pReal - point(1) - point(2), point(1), & - 1.0_pReal - point(1) - point(2), point(2), point(1), & - 1.0_pReal - point(1) - point(2), point(1), point(2)],[3,6])),.true.) + point(1), point(2), 1.0_pREAL - point(1) - point(2), & + point(1), 1.0_pREAL - point(1) - point(2), point(2), & + point(2), point(1), 1.0_pREAL - point(1) - point(2), & + point(2), 1.0_pREAL - point(1) - point(2), point(1), & + 1.0_pREAL - point(1) - point(2), point(2), point(1), & + 1.0_pREAL - point(1) - point(2), point(1), point(2)],[3,6])),.true.) end function permutationStar111 @@ -240,8 +240,8 @@ end function permutationStar111 !-------------------------------------------------------------------------------------------------- pure function permutationStar4(point) result(qPt) - real(pReal), dimension(3) :: qPt - real(pReal), dimension(1), intent(in) :: point + real(pREAL), dimension(3) :: qPt + real(pREAL), dimension(1), intent(in) :: point qPt = pack(matmul(tetrahedron,reshape([ & @@ -255,15 +255,15 @@ end function permutationStar4 !-------------------------------------------------------------------------------------------------- pure function permutationStar31(point) result(qPt) - real(pReal), dimension(12) :: qPt - real(pReal), dimension(1), intent(in) :: point + real(pREAL), dimension(12) :: qPt + real(pREAL), dimension(1), intent(in) :: point qPt = pack(matmul(tetrahedron,reshape([ & - point(1), point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), & - point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), & - point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), point(1), & - 1.0_pReal - 3.0_pReal*point(1), point(1), point(1), point(1)],[4,4])),.true.) + point(1), point(1), point(1), 1.0_pREAL - 3.0_pREAL*point(1), & + point(1), point(1), 1.0_pREAL - 3.0_pREAL*point(1), point(1), & + point(1), 1.0_pREAL - 3.0_pREAL*point(1), point(1), point(1), & + 1.0_pREAL - 3.0_pREAL*point(1), point(1), point(1), point(1)],[4,4])),.true.) end function permutationStar31 @@ -273,17 +273,17 @@ end function permutationStar31 !-------------------------------------------------------------------------------------------------- function permutationStar22(point) result(qPt) - real(pReal), dimension(18) :: qPt - real(pReal), dimension(1), intent(in) :: point + real(pREAL), dimension(18) :: qPt + real(pREAL), dimension(1), intent(in) :: point qPt = pack(matmul(tetrahedron,reshape([ & - point(1), point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), & - point(1), 0.5_pReal - point(1), point(1), 0.5_pReal - point(1), & - 0.5_pReal - point(1), point(1), point(1), 0.5_pReal - point(1), & - 0.5_pReal - point(1), point(1), 0.5_pReal - point(1), point(1), & - 0.5_pReal - point(1), 0.5_pReal - point(1), point(1), point(1), & - point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), point(1)],[4,6])),.true.) + point(1), point(1), 0.5_pREAL - point(1), 0.5_pREAL - point(1), & + point(1), 0.5_pREAL - point(1), point(1), 0.5_pREAL - point(1), & + 0.5_pREAL - point(1), point(1), point(1), 0.5_pREAL - point(1), & + 0.5_pREAL - point(1), point(1), 0.5_pREAL - point(1), point(1), & + 0.5_pREAL - point(1), 0.5_pREAL - point(1), point(1), point(1), & + point(1), 0.5_pREAL - point(1), 0.5_pREAL - point(1), point(1)],[4,6])),.true.) end function permutationStar22 @@ -293,23 +293,23 @@ end function permutationStar22 !-------------------------------------------------------------------------------------------------- pure function permutationStar211(point) result(qPt) - real(pReal), dimension(36) :: qPt - real(pReal), dimension(2), intent(in) :: point + real(pREAL), dimension(36) :: qPt + real(pREAL), dimension(2), intent(in) :: point qPt = pack(matmul(tetrahedron,reshape([ & - point(1), point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), & - point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), & - point(1), point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), & - point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), & - point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), & - point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), & - point(2), point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), & - point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), & - point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), & - 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), point(2), & - 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), point(1), & - 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.) + point(1), point(1), point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), & + point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), & + point(1), point(2), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), & + point(1), point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), & + point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(2), & + point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), point(1), & + point(2), point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), & + point(2), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), & + point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(1), & + 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(1), point(2), & + 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(2), point(1), & + 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.) end function permutationStar211 @@ -319,35 +319,35 @@ end function permutationStar211 !-------------------------------------------------------------------------------------------------- pure function permutationStar1111(point) result(qPt) - real(pReal), dimension(72) :: qPt - real(pReal), dimension(3), intent(in) :: point + real(pREAL), dimension(72) :: qPt + real(pREAL), dimension(3), intent(in) :: point qPt = pack(matmul(tetrahedron,reshape([ & - point(1), point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), & - point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), & - point(1), point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), & - point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), & - point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), & - point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), & - point(2), point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), & - point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), & - point(2), point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), & - point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), & - point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), & - point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), & - point(3), point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), & - point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), & - point(3), point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), & - point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), & - point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), & - point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), & - 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), point(3), & - 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), point(2), & - 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), point(3), & - 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), point(1), & - 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), point(2), & - 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.) + point(1), point(2), point(3), 1.0_pREAL - point(1) - point(2)- point(3), & + point(1), point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(3), & + point(1), point(3), point(2), 1.0_pREAL - point(1) - point(2)- point(3), & + point(1), point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(2), & + point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(3), & + point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(2), & + point(2), point(1), point(3), 1.0_pREAL - point(1) - point(2)- point(3), & + point(2), point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(3), & + point(2), point(3), point(1), 1.0_pREAL - point(1) - point(2)- point(3), & + point(2), point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(1), & + point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(3), & + point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(1), & + point(3), point(1), point(2), 1.0_pREAL - point(1) - point(2)- point(3), & + point(3), point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(2), & + point(3), point(2), point(1), 1.0_pREAL - point(1) - point(2)- point(3), & + point(3), point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(1), & + point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(2), & + point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(1), & + 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(2), point(3), & + 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(3), point(2), & + 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(1), point(3), & + 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(3), point(1), & + 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(1), point(2), & + 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.) end function permutationStar1111 @@ -358,12 +358,12 @@ end function permutationStar1111 subroutine selfTest integer :: o, d, n - real(pReal), dimension(2:3), parameter :: w = [3.0_pReal,2.0_pReal] + real(pREAL), dimension(2:3), parameter :: w = [3.0_pREAL,2.0_pREAL] do d = lbound(FEM_quadrature_weights,1), ubound(FEM_quadrature_weights,1) do o = lbound(FEM_quadrature_weights(d,:),1), ubound(FEM_quadrature_weights(d,:),1) - if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pReal,5e-15_pReal)) & + if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pREAL,5e-15_pREAL)) & error stop 'quadrature weights' end do end do @@ -371,7 +371,7 @@ subroutine selfTest do d = lbound(FEM_quadrature_points,1), ubound(FEM_quadrature_points,1) do o = lbound(FEM_quadrature_points(d,:),1), ubound(FEM_quadrature_points(d,:),1) n = size(FEM_quadrature_points(d,o)%p,1)/d - if (any(dNeq(sum(reshape(FEM_quadrature_points(d,o)%p,[d,n]),2),-real(n,pReal)/w(d),1.e-14_pReal))) & + if (any(dNeq(sum(reshape(FEM_quadrature_points(d,o)%p,[d,n]),2),-real(n,pREAL)/w(d),1.e-14_pREAL))) & error stop 'quadrature points' end do end do diff --git a/src/mesh/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 index 2eab945d9..d30b223f0 100644 --- a/src/mesh/FEM_utilities.f90 +++ b/src/mesh/FEM_utilities.f90 @@ -29,7 +29,7 @@ module FEM_utilities private logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill - real(pReal), public, protected :: wgt !< weighting factor 1/Nelems + real(pREAL), public, protected :: wgt !< weighting factor 1/Nelems !-------------------------------------------------------------------------------------------------- @@ -59,7 +59,7 @@ module FEM_utilities type, public :: tComponentBC integer(kind(COMPONENT_UNDEFINED_ID)) :: ID - real(pReal), allocatable, dimension(:) :: Value + real(pREAL), allocatable, dimension(:) :: Value logical, allocatable, dimension(:) :: Mask end type tComponentBC @@ -128,7 +128,7 @@ subroutine FEM_utilities_init call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),err_PETSc) CHKERRQ(err_PETSc) - wgt = real(mesh_maxNips*mesh_NcpElemsGlobal,pReal)**(-1) + wgt = real(mesh_maxNips*mesh_NcpElemsGlobal,pREAL)**(-1) end subroutine FEM_utilities_init @@ -139,9 +139,9 @@ end subroutine FEM_utilities_init !-------------------------------------------------------------------------------------------------- subroutine utilities_constitutiveResponse(timeinc,P_av,forwardData) - real(pReal), intent(in) :: timeinc !< loading time + real(pREAL), intent(in) :: timeinc !< loading time logical, intent(in) :: forwardData !< age results - real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress + real(pREAL),intent(out), dimension(3,3) :: P_av !< average PK stress integer(MPI_INTEGER_KIND) :: err_MPI @@ -170,8 +170,8 @@ subroutine utilities_projectBCValues(localVec,section,field,comp,bcPointsIS,BCVa PetscSection :: section IS :: bcPointsIS PetscInt, pointer :: bcPoints(:) - real(pReal), pointer :: localArray(:) - real(pReal) :: BCValue,BCDotValue,timeinc + real(pREAL), pointer :: localArray(:) + real(pREAL) :: BCValue,BCDotValue,timeinc PetscErrorCode :: err_PETSc diff --git a/src/mesh/discretization_mesh.f90 b/src/mesh/discretization_mesh.f90 index b8505f3cb..5cd12549e 100644 --- a/src/mesh/discretization_mesh.f90 +++ b/src/mesh/discretization_mesh.f90 @@ -49,11 +49,11 @@ module discretization_mesh PetscInt, dimension(:), allocatable, public, protected :: & mesh_boundaries - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & mesh_ipVolume, & !< volume associated with IP (initially!) mesh_node0 !< node x,y,z coordinates (initially!) - real(pReal), dimension(:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:), allocatable :: & mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) #ifdef PETSC_USE_64BIT_INDICES @@ -92,7 +92,7 @@ subroutine discretization_mesh_init(restart) num_mesh integer :: p_i, dim !< integration order (quadrature rule) type(tvec) :: coords_node0 - real(pReal), pointer, dimension(:) :: & + real(pREAL), pointer, dimension(:) :: & mesh_node0_temp print'(/,1x,a)', '<<<+- discretization_mesh init -+>>>' @@ -176,7 +176,7 @@ subroutine discretization_mesh_init(restart) end do materialAt = materialAt + 1_pPETSCINT - allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pReal) + allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pREAL) mesh_node0(1:dimPlex,:) = reshape(mesh_node0_temp,[dimPlex,mesh_Nnodes]) @@ -200,7 +200,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex) PetscInt :: cellStart, cellEnd, cell PetscErrorCode :: err_PETSc - allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems),source=0.0_pReal) + allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems),source=0.0_pREAL) call DMPlexGetHeightStratum(geomMesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc) CHKERRQ(err_PETSc) @@ -209,7 +209,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex) do cell = cellStart, cellEnd-1 call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc) CHKERRQ(err_PETSc) - mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal) + mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pREAL) end do end subroutine mesh_FEM_build_ipVolumes @@ -229,7 +229,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints) PetscErrorCode :: err_PETSc - allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems),source=0.0_pReal) + allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems),source=0.0_pREAL) allocate(pV0(dimPlex)) allocatE(pCellJ(dimPlex**2)) @@ -245,7 +245,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints) mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI) do dirJ = 1_pPETSCINT, dimPlex mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + & - pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal) + pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pREAL) end do end do qOffset = qOffset + dimPlex @@ -259,7 +259,7 @@ end subroutine mesh_FEM_build_ipCoordinates !-------------------------------------------------------------------------------------------------- subroutine writeGeometry(coordinates_points,coordinates_nodes) - real(pReal), dimension(:,:), intent(in) :: & + real(pREAL), dimension(:,:), intent(in) :: & coordinates_nodes, & coordinates_points diff --git a/src/mesh/mesh_mech_FEM.f90 b/src/mesh/mesh_mech_FEM.f90 index 930299a67..a12738fd4 100644 --- a/src/mesh/mesh_mech_FEM.f90 +++ b/src/mesh/mesh_mech_FEM.f90 @@ -37,7 +37,7 @@ module mesh_mechanical_FEM ! derived types type tSolutionParams type(tFieldBC) :: fieldBC - real(pReal) :: timeinc + real(pREAL) :: timeinc end type tSolutionParams type(tSolutionParams) :: params @@ -48,7 +48,7 @@ module mesh_mechanical_FEM itmax logical :: & BBarStabilisation - real(pReal) :: & + real(pREAL) :: & eps_struct_atol, & !< absolute tolerance for mechanical equilibrium eps_struct_rtol !< relative tolerance for mechanical equilibrium end type tNumerics @@ -66,10 +66,10 @@ module mesh_mechanical_FEM !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. character(len=pSTRLEN) :: incInfo - real(pReal), dimension(3,3) :: & - P_av = 0.0_pReal + real(pREAL), dimension(3,3) :: & + P_av = 0.0_pREAL logical :: ForwardData - real(pReal), parameter :: eps = 1.0e-18_pReal + real(pREAL), parameter :: eps = 1.0e-18_pREAL external :: & ! ToDo: write interfaces #ifdef PETSC_USE_64BIT_INDICES @@ -120,12 +120,12 @@ subroutine FEM_mechanical_init(fieldBC) PetscReal :: detJ PetscReal, allocatable, target :: cellJMat(:,:) - real(pReal), pointer, dimension(:) :: px_scal - real(pReal), allocatable, target, dimension(:) :: x_scal + real(pREAL), pointer, dimension(:) :: px_scal + real(pREAL), allocatable, target, dimension(:) :: x_scal character(len=*), parameter :: prefix = 'mechFE_' PetscErrorCode :: err_PETSc - real(pReal), dimension(3,3) :: devNull + real(pREAL), dimension(3,3) :: devNull type(tDict), pointer :: & num_mesh @@ -137,12 +137,12 @@ subroutine FEM_mechanical_init(fieldBC) num%p_i = int(num_mesh%get_asInt('p_i',defaultVal = 2),pPETSCINT) num%itmax = int(num_mesh%get_asInt('itmax',defaultVal=250),pPETSCINT) num%BBarStabilisation = num_mesh%get_asBool('bbarstabilisation',defaultVal = .false.) - num%eps_struct_atol = num_mesh%get_asReal('eps_struct_atol', defaultVal = 1.0e-10_pReal) - num%eps_struct_rtol = num_mesh%get_asReal('eps_struct_rtol', defaultVal = 1.0e-4_pReal) + num%eps_struct_atol = num_mesh%get_asReal('eps_struct_atol', defaultVal = 1.0e-10_pREAL) + num%eps_struct_rtol = num_mesh%get_asReal('eps_struct_rtol', defaultVal = 1.0e-4_pREAL) if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') - if (num%eps_struct_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_rtol') - if (num%eps_struct_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_atol') + if (num%eps_struct_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_struct_rtol') + if (num%eps_struct_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_struct_atol') !-------------------------------------------------------------------------------------------------- ! Setup FEM mech mesh @@ -264,16 +264,16 @@ subroutine FEM_mechanical_init(fieldBC) CHKERRQ(err_PETSc) call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,err_PETSc) CHKERRQ(err_PETSc) - call SNESSetTolerances(mechanical_snes,1.0_pReal,0.0_pReal,0.0_pReal,num%itmax,num%itmax,err_PETSc) + call SNESSetTolerances(mechanical_snes,1.0_pREAL,0.0_pREAL,0.0_pREAL,num%itmax,num%itmax,err_PETSc) CHKERRQ(err_PETSc) call SNESSetFromOptions(mechanical_snes,err_PETSc) CHKERRQ(err_PETSc) !-------------------------------------------------------------------------------------------------- ! init fields - call VecSet(solution ,0.0_pReal,err_PETSc) + call VecSet(solution ,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(solution_rate,0.0_pReal,err_PETSc) + call VecSet(solution_rate,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) allocate(x_scal(cellDof)) allocate(nodalWeightsP(1)) @@ -289,7 +289,7 @@ subroutine FEM_mechanical_init(fieldBC) call DMPlexGetHeightStratum(mechanical_mesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc) CHKERRQ(err_PETSc) do cell = cellStart, cellEnd-1 !< loop over all elements - x_scal = 0.0_pReal + x_scal = 0.0_pREAL call DMPlexComputeCellGeometryAffineFEM(mechanical_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) CHKERRQ(err_PETSc) cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex]) @@ -298,13 +298,13 @@ subroutine FEM_mechanical_init(fieldBC) CHKERRQ(err_PETSc) call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,err_PETSc) CHKERRQ(err_PETSc) - x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pReal) + x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pREAL) end do px_scal => x_scal call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc) CHKERRQ(err_PETSc) end do - call utilities_constitutiveResponse(0.0_pReal,devNull,.true.) + call utilities_constitutiveResponse(0.0_pREAL,devNull,.true.) end subroutine FEM_mechanical_init @@ -317,7 +317,7 @@ type(tSolutionState) function FEM_mechanical_solution( & !-------------------------------------------------------------------------------------------------- ! input data for solution - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & timeinc, & !< increment in time for current solution timeinc_old !< increment in time of last increment type(tFieldBC), intent(in) :: & @@ -369,8 +369,8 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc PetscDS :: prob Vec :: x_local, f_local, xx_local PetscSection :: section - real(pReal), dimension(:), pointer :: x_scal, pf_scal - real(pReal), dimension(cellDof), target :: f_scal + real(pREAL), dimension(:), pointer :: x_scal, pf_scal + real(pREAL), dimension(cellDof), target :: f_scal PetscReal :: IcellJMat(dimPlex,dimPlex) PetscReal, dimension(:),pointer :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer PetscInt :: cellStart, cellEnd, cell, field, face, & @@ -397,7 +397,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc CHKERRQ(err_PETSc) call DMGetLocalVector(dm_local,x_local,err_PETSc) CHKERRQ(err_PETSc) - call VecWAXPY(x_local,1.0_pReal,xx_local,solution_local,err_PETSc) + call VecWAXPY(x_local,1.0_pREAL,xx_local,solution_local,err_PETSc) CHKERRQ(err_PETSc) do field = 1_pPETSCINT, dimPlex; do face = 1_pPETSCINT, mesh_Nboundaries if (params%fieldBC%componentBC(field)%Mask(face)) then @@ -406,7 +406,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) CHKERRQ(err_PETSc) call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, & - 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + 0.0_pREAL,params%fieldBC%componentBC(field)%Value(face),params%timeinc) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) end if @@ -426,7 +426,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT m = cell*nQuadrature + qPt+1_pPETSCINT - BMat = 0.0_pReal + BMat = 0.0_pREAL do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT cidx = basis*dimPlex+comp @@ -438,11 +438,11 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) end do if (num%BBarStabilisation) then - detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pReal)) + detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pREAL)) do qPt = 0, nQuadrature-1 m = cell*nQuadrature + qPt+1 homogenization_F(1:dimPlex,1:dimPlex,m) = homogenization_F(1:dimPlex,1:dimPlex,m) & - * (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pReal/real(dimPlex,pReal)) + * (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pREAL/real(dimPlex,pREAL)) end do end if @@ -465,10 +465,10 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) CHKERRQ(err_PETSc) IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) - f_scal = 0.0_pReal + f_scal = 0.0_pREAL do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT m = cell*nQuadrature + qPt+1_pPETSCINT - BMat = 0.0_pReal + BMat = 0.0_pREAL do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT cidx = basis*dimPlex+comp @@ -517,10 +517,10 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & pV0, pCellJ, pInvcellJ - real(pReal), dimension(:), pointer :: pK_e, x_scal + real(pREAL), dimension(:), pointer :: pK_e, x_scal - real(pReal),dimension(cellDOF,cellDOF), target :: K_e - real(pReal),dimension(cellDOF,cellDOF) :: K_eA, K_eB + real(pREAL),dimension(cellDOF,cellDOF), target :: K_e + real(pREAL),dimension(cellDOF,cellDOF) :: K_eA, K_eB PetscInt :: cellStart, cellEnd, cell, field, face, & qPt, basis, comp, cidx,bcSize, m, i @@ -547,7 +547,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P call DMGetLocalVector(dm_local,x_local,err_PETSc) CHKERRQ(err_PETSc) - call VecWAXPY(x_local,1.0_pReal,xx_local,solution_local,err_PETSc) + call VecWAXPY(x_local,1.0_pREAL,xx_local,solution_local,err_PETSc) CHKERRQ(err_PETSc) do field = 1, dimPlex; do face = 1, mesh_Nboundaries if (params%fieldBC%componentBC(field)%Mask(face)) then @@ -556,7 +556,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) CHKERRQ(err_PETSc) call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, & - 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + 0.0_pREAL,params%fieldBC%componentBC(field)%Value(face),params%timeinc) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) end if @@ -569,14 +569,14 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P CHKERRQ(err_PETSc) call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) CHKERRQ(err_PETSc) - K_eA = 0.0_pReal - K_eB = 0.0_pReal - MatB = 0.0_pReal - FAvg = 0.0_pReal - BMatAvg = 0.0_pReal + K_eA = 0.0_pREAL + K_eB = 0.0_pREAL + MatB = 0.0_pREAL + FAvg = 0.0_pREAL + BMatAvg = 0.0_pREAL do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT m = cell*nQuadrature + qPt + 1_pPETSCINT - BMat = 0.0_pReal + BMat = 0.0_pREAL do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT cidx = basis*dimPlex+comp @@ -591,7 +591,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P if (num%BBarStabilisation) then F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex]) FInv = math_inv33(F) - K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0_pReal/real(dimPlex,pReal)) + K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0_pREAL/real(dimPlex,pREAL)) K_eB = K_eB - & matmul(transpose(matmul(reshape(homogenization_F(1:dimPlex,1:dimPlex,m),shape=[dimPlex**2,1_pPETSCINT]), & matmul(reshape(FInv(1:dimPlex,1:dimPlex), & @@ -606,10 +606,10 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P end do if (num%BBarStabilisation) then FInv = math_inv33(FAvg) - K_e = K_eA*math_det33(FAvg/real(nQuadrature,pReal))**(1.0_pReal/real(dimPlex,pReal)) + & + K_e = K_eA*math_det33(FAvg/real(nQuadrature,pREAL))**(1.0_pREAL/real(dimPlex,pREAL)) + & (matmul(matmul(transpose(BMatAvg), & reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex**2,1_pPETSCINT],order=[2,1])),MatB) + & - K_eB)/real(dimPlex,pReal) + K_eB)/real(dimPlex,pREAL) else K_e = K_eA end if @@ -662,7 +662,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC) type(tFieldBC), intent(in) :: & fieldBC - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & timeinc_old, & timeinc logical, intent(in) :: & @@ -686,13 +686,13 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC) CHKERRQ(err_PETSc) call DMGetLocalVector(dm_local,x_local,err_PETSc) CHKERRQ(err_PETSc) - call VecSet(x_local,0.0_pReal,err_PETSc) + call VecSet(x_local,0.0_pREAL,err_PETSc) CHKERRQ(err_PETSc) call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) !< retrieve my partition of global solution vector CHKERRQ(err_PETSc) call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) CHKERRQ(err_PETSc) - call VecAXPY(solution_local,1.0_pReal,x_local,err_PETSc) + call VecAXPY(solution_local,1.0_pREAL,x_local,err_PETSc) CHKERRQ(err_PETSc) do field = 1, dimPlex; do face = 1, mesh_Nboundaries if (fieldBC%componentBC(field)%Mask(face)) then @@ -701,7 +701,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC) call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) CHKERRQ(err_PETSc) call utilities_projectBCValues(solution_local,section,0_pPETSCINT,field-1,bcPoints, & - 0.0_pReal,fieldBC%componentBC(field)%Value(face),timeinc_old) + 0.0_pREAL,fieldBC%componentBC(field)%Value(face),timeinc_old) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) end if @@ -746,7 +746,7 @@ subroutine FEM_mechanical_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reaso print'(/,1x,a,a,i0,a,f0.3)', trim(incInfo), & ' @ Iteration ',PETScIter,' mechanical residual norm = ',fnorm/divTol print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & - 'Piola--Kirchhoff stress / MPa =',transpose(P_av)*1.e-6_pReal + 'Piola--Kirchhoff stress / MPa =',transpose(P_av)*1.e-6_pREAL flush(IO_STDOUT) end subroutine FEM_mechanical_converged @@ -759,7 +759,7 @@ subroutine FEM_mechanical_updateCoords() PetscReal, pointer, dimension(:,:) :: & nodeCoords !< nodal coordinates (3,Nnodes) - real(pReal), pointer, dimension(:,:,:) :: & + real(pREAL), pointer, dimension(:,:,:) :: & ipCoords !< ip coordinates (3,nQuadrature,mesh_NcpElems) integer :: & @@ -777,7 +777,7 @@ subroutine FEM_mechanical_updateCoords() PetscQuadrature :: mechQuad PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & nodeCoords_linear !< nodal coordinates (dimPlex*Nnodes) - real(pReal), dimension(:), pointer :: x_scal + real(pREAL), dimension(:), pointer :: x_scal call SNESGetDM(mechanical_snes,dm_local,err_PETSc) CHKERRQ(err_PETSc) @@ -793,7 +793,7 @@ subroutine FEM_mechanical_updateCoords() ! write cell vertex displacements call DMPlexGetDepthStratum(dm_local,0_pPETSCINT,pStart,pEnd,err_PETSc) CHKERRQ(err_PETSc) - allocate(nodeCoords(3,pStart:pEnd-1),source=0.0_pReal) + allocate(nodeCoords(3,pStart:pEnd-1),source=0.0_pREAL) call VecGetArrayF90(x_local,nodeCoords_linear,err_PETSc) CHKERRQ(err_PETSc) do p=pStart, pEnd-1 @@ -811,7 +811,7 @@ subroutine FEM_mechanical_updateCoords() CHKERRQ(err_PETSc) call PetscDSGetTabulation(mechQuad,0_pPETSCINT,basisField,basisFieldDer,err_PETSc) CHKERRQ(err_PETSc) - allocate(ipCoords(3,nQuadrature,mesh_NcpElems),source=0.0_pReal) + allocate(ipCoords(3,nQuadrature,mesh_NcpElems),source=0.0_pREAL) do c=cellStart,cellEnd-1_pPETSCINT qOffset=0 call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc) !< get nodal coordinates of each element diff --git a/src/misc.f90 b/src/misc.f90 index c912bc744..0ba3d6970 100644 --- a/src/misc.f90 +++ b/src/misc.f90 @@ -78,9 +78,9 @@ end function misc_optional_int !-------------------------------------------------------------------------------------------------- pure function misc_optional_real(given,default) result(var) - real(pReal), intent(in), optional :: given - real(pReal), intent(in) :: default - real(pReal) :: var + real(pREAL), intent(in), optional :: given + real(pREAL), intent(in) :: default + real(pREAL) :: var if (present(given)) then @@ -116,7 +116,7 @@ end function misc_optional_str !-------------------------------------------------------------------------------------------------- subroutine misc_selfTest() - real(pReal) :: r + real(pREAL) :: r call random_number(r) if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_str, present' @@ -126,11 +126,11 @@ subroutine misc_selfTest() if (test_int() /= 42) error stop 'optional_int, not present' if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only' if (dNeq(test_real(r),r)) error stop 'optional_real, present' - if (dNeq(test_real(),0.0_pReal)) error stop 'optional_real, not present' + if (dNeq(test_real(),0.0_pREAL)) error stop 'optional_real, not present' if (dNeq(misc_optional(default=r),r)) error stop 'optional_real, default only' - if (test_bool(r<0.5_pReal) .neqv. r<0.5_pReal) error stop 'optional_bool, present' + if (test_bool(r<0.5_pREAL) .neqv. r<0.5_pREAL) error stop 'optional_bool, present' if (.not. test_bool()) error stop 'optional_bool, not present' - if (misc_optional(default=r>0.5_pReal) .neqv. r>0.5_pReal) error stop 'optional_bool, default only' + if (misc_optional(default=r>0.5_pREAL) .neqv. r>0.5_pREAL) error stop 'optional_bool, default only' contains @@ -158,11 +158,11 @@ contains function test_real(real_in) result(real_out) - real(pReal) :: real_out - real(pReal), intent(in), optional :: real_in + real(pREAL) :: real_out + real(pREAL), intent(in), optional :: real_in - real_out = misc_optional_real(real_in,0.0_pReal) + real_out = misc_optional_real(real_in,0.0_pREAL) end function test_real diff --git a/src/parallelization.f90 b/src/parallelization.f90 index b5f3daae8..46b94af53 100644 --- a/src/parallelization.f90 +++ b/src/parallelization.f90 @@ -135,8 +135,8 @@ subroutine parallelization_init() call MPI_Type_size(MPI_DOUBLE,typeSize,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) & error stop 'Could not determine size of MPI_DOUBLE' - if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pReal),MPI_INTEGER_KIND)) & - error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal' + if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pREAL),MPI_INTEGER_KIND)) & + error stop 'Mismatch between MPI_DOUBLE and DAMASK pREAL' !$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env) !$ if (got_env /= 0) then diff --git a/src/phase.f90 b/src/phase.f90 index 6162b6c0a..f889a854f 100644 --- a/src/phase.f90 +++ b/src/phase.f90 @@ -29,15 +29,15 @@ module phase sizeDotState = 0, & !< size of dot state, i.e. state(1:sizeDot) follows time evolution by dotState rates offsetDeltaState = 0, & !< index offset of delta state sizeDeltaState = 0 !< size of delta state, i.e. state(offset+1:offset+sizeDelta) follows time evolution by deltaState increments - real(pReal), allocatable, dimension(:) :: & + real(pREAL), allocatable, dimension(:) :: & atol ! http://stackoverflow.com/questions/3948210 - real(pReal), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer + real(pREAL), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer state0, & state, & !< state dotState, & !< rate of state change deltaState !< increment of state change - real(pReal), pointer, dimension(:,:) :: & + real(pREAL), pointer, dimension(:,:) :: & deltaState2 end type @@ -51,8 +51,8 @@ module phase character(len=2), allocatable, dimension(:) :: phase_lattice - real(pReal), allocatable, dimension(:) :: phase_cOverA - real(pReal), allocatable, dimension(:) :: phase_rho + real(pREAL), allocatable, dimension(:) :: phase_cOverA + real(pREAL), allocatable, dimension(:) :: phase_rho type(tRotationContainer), dimension(:), allocatable :: & phase_O_0, & @@ -63,7 +63,7 @@ module phase iJacoLpresiduum, & !< frequency of Jacobian update of residuum in Lp nState, & !< state loop limit nStress !< stress loop limit - real(pReal) :: & + real(pREAL) :: & subStepMinCryst, & !< minimum (relative) size of sub-step allowed during cutback subStepSizeCryst, & !< size of first substep when cutback subStepSizeLp, & !< size of first substep when cutback in Lp calculation @@ -133,11 +133,11 @@ module phase module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & co, & !< counter in constituent loop ce - real(pReal), dimension(3,3,3,3) :: dPdF + real(pREAL), dimension(3,3,3,3) :: dPdF end function phase_mechanical_dPdF module subroutine mechanical_restartWrite(groupHandle,ph) @@ -172,105 +172,105 @@ module phase module function mechanical_S(ph,en) result(S) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: S + real(pREAL), dimension(3,3) :: S end function mechanical_S module function mechanical_L_p(ph,en) result(L_p) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: L_p + real(pREAL), dimension(3,3) :: L_p end function mechanical_L_p module function mechanical_F_e(ph,en) result(F_e) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: F_e + real(pREAL), dimension(3,3) :: F_e end function mechanical_F_e module function mechanical_F_i(ph,en) result(F_i) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: F_i + real(pREAL), dimension(3,3) :: F_i end function mechanical_F_i module function phase_F(co,ce) result(F) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: F + real(pREAL), dimension(3,3) :: F end function phase_F module function phase_P(co,ce) result(P) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: P + real(pREAL), dimension(3,3) :: P end function phase_P pure module function thermal_T(ph,en) result(T) integer, intent(in) :: ph,en - real(pReal) :: T + real(pREAL) :: T end function thermal_T module function thermal_dot_T(ph,en) result(dot_T) integer, intent(in) :: ph,en - real(pReal) :: dot_T + real(pREAL) :: dot_T end function thermal_dot_T module function damage_phi(ph,en) result(phi) integer, intent(in) :: ph,en - real(pReal) :: phi + real(pREAL) :: phi end function damage_phi module subroutine phase_set_F(F,co,ce) - real(pReal), dimension(3,3), intent(in) :: F + real(pREAL), dimension(3,3), intent(in) :: F integer, intent(in) :: co, ce end subroutine phase_set_F module subroutine phase_thermal_setField(T,dot_T, co,ce) - real(pReal), intent(in) :: T, dot_T + real(pREAL), intent(in) :: T, dot_T integer, intent(in) :: co, ce end subroutine phase_thermal_setField module subroutine phase_set_phi(phi,co,ce) - real(pReal), intent(in) :: phi + real(pREAL), intent(in) :: phi integer, intent(in) :: co, ce end subroutine phase_set_phi module function phase_mu_phi(co,ce) result(mu) integer, intent(in) :: co, ce - real(pReal) :: mu + real(pREAL) :: mu end function phase_mu_phi module function phase_K_phi(co,ce) result(K) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K end function phase_K_phi module function phase_mu_T(co,ce) result(mu) integer, intent(in) :: co, ce - real(pReal) :: mu + real(pREAL) :: mu end function phase_mu_T module function phase_K_T(co,ce) result(K) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K end function phase_K_T ! == cleaned:end =================================================================================== module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en logical :: converged_ end function phase_thermal_constitutive module function phase_damage_constitutive(Delta_t,co,ce) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: co, ce logical :: converged_ end function phase_damage_constitutive module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: co, ce logical :: converged_ end function phase_mechanical_constitutive @@ -278,25 +278,25 @@ module phase !ToDo: Merge all the stiffness functions module function phase_homogenizedC66(ph,en) result(C) integer, intent(in) :: ph, en - real(pReal), dimension(6,6) :: C + real(pREAL), dimension(6,6) :: C end function phase_homogenizedC66 module function phase_damage_C66(C66,ph,en) result(C66_degraded) - real(pReal), dimension(6,6), intent(in) :: C66 + real(pREAL), dimension(6,6), intent(in) :: C66 integer, intent(in) :: ph,en - real(pReal), dimension(6,6) :: C66_degraded + real(pREAL), dimension(6,6) :: C66_degraded end function phase_damage_C66 module function phase_f_phi(phi,co,ce) result(f) integer, intent(in) :: ce,co - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & phi !< damage parameter - real(pReal) :: & + real(pREAL) :: & f end function phase_f_phi module function phase_f_T(ph,en) result(f) integer, intent(in) :: ph, en - real(pReal) :: f + real(pREAL) :: f end function phase_f_T module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) @@ -316,11 +316,11 @@ module phase module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en) integer, intent(in) :: ph, en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & M_i - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & L_i !< damage velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dL_i_dM_i !< derivative of L_i with respect to M_i end subroutine damage_anisobrittle_LiAndItsTangent @@ -389,7 +389,7 @@ subroutine phase_init phases => config_material%get_dict('phase') allocate(phase_lattice(phases%length)) - allocate(phase_cOverA(phases%length),source=-1.0_pReal) + allocate(phase_cOverA(phases%length),source=-1.0_pREAL) allocate(phase_rho(phases%length)) allocate(phase_O_0(phases%length)) @@ -403,7 +403,7 @@ subroutine phase_init call IO_error(130,ext_msg='phase_init: '//phase%get_asStr('lattice')) if (any(phase_lattice(ph) == ['hP','tI'])) & phase_cOverA(ph) = phase%get_asReal('c/a') - phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pReal) + phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pREAL) allocate(phase_O_0(ph)%data(count(material_ID_phase==ph))) end do @@ -454,13 +454,13 @@ subroutine phase_allocateState(state, & state%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition end if - allocate(state%atol (sizeState), source=0.0_pReal) - allocate(state%state0 (sizeState,NEntries), source=0.0_pReal) - allocate(state%state (sizeState,NEntries), source=0.0_pReal) + allocate(state%atol (sizeState), source=0.0_pREAL) + allocate(state%state0 (sizeState,NEntries), source=0.0_pREAL) + allocate(state%state (sizeState,NEntries), source=0.0_pREAL) - allocate(state%dotState (sizeDotState,NEntries), source=0.0_pReal) + allocate(state%dotState (sizeDotState,NEntries), source=0.0_pREAL) - allocate(state%deltaState (sizeDeltaState,NEntries), source=0.0_pReal) + allocate(state%deltaState (sizeDeltaState,NEntries), source=0.0_pREAL) state%deltaState2 => state%state(state%offsetDeltaState+1: & state%offsetDeltaState+state%sizeDeltaState,:) @@ -538,27 +538,27 @@ subroutine crystallite_init() num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict) - num%subStepMinCryst = num_crystallite%get_asReal ('subStepMin', defaultVal=1.0e-3_pReal) - num%subStepSizeCryst = num_crystallite%get_asReal ('subStepSize', defaultVal=0.25_pReal) - num%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.5_pReal) - num%subStepSizeLp = num_crystallite%get_asReal ('subStepSizeLp', defaultVal=0.5_pReal) - num%subStepSizeLi = num_crystallite%get_asReal ('subStepSizeLi', defaultVal=0.5_pReal) - num%rtol_crystalliteState = num_crystallite%get_asReal ('rtol_State', defaultVal=1.0e-6_pReal) - num%rtol_crystalliteStress = num_crystallite%get_asReal ('rtol_Stress', defaultVal=1.0e-6_pReal) - num%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pReal) + num%subStepMinCryst = num_crystallite%get_asReal ('subStepMin', defaultVal=1.0e-3_pREAL) + num%subStepSizeCryst = num_crystallite%get_asReal ('subStepSize', defaultVal=0.25_pREAL) + num%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.5_pREAL) + num%subStepSizeLp = num_crystallite%get_asReal ('subStepSizeLp', defaultVal=0.5_pREAL) + num%subStepSizeLi = num_crystallite%get_asReal ('subStepSizeLi', defaultVal=0.5_pREAL) + num%rtol_crystalliteState = num_crystallite%get_asReal ('rtol_State', defaultVal=1.0e-6_pREAL) + num%rtol_crystalliteStress = num_crystallite%get_asReal ('rtol_Stress', defaultVal=1.0e-6_pREAL) + num%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pREAL) num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1) num%nState = num_crystallite%get_asInt ('nState', defaultVal=20) num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40) extmsg = '' - if (num%subStepMinCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepMinCryst' - if (num%subStepSizeCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeCryst' - if (num%stepIncreaseCryst <= 0.0_pReal) extmsg = trim(extmsg)//' stepIncreaseCryst' - if (num%subStepSizeLp <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLp' - if (num%subStepSizeLi <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLi' - if (num%rtol_crystalliteState <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteState' - if (num%rtol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteStress' - if (num%atol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_crystalliteStress' + if (num%subStepMinCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepMinCryst' + if (num%subStepSizeCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeCryst' + if (num%stepIncreaseCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' stepIncreaseCryst' + if (num%subStepSizeLp <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeLp' + if (num%subStepSizeLi <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeLi' + if (num%rtol_crystalliteState <= 0.0_pREAL) extmsg = trim(extmsg)//' rtol_crystalliteState' + if (num%rtol_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' rtol_crystalliteStress' + if (num%atol_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' atol_crystalliteStress' if (num%iJacoLpresiduum < 1) extmsg = trim(extmsg)//' iJacoLpresiduum' if (num%nState < 1) extmsg = trim(extmsg)//' nState' if (num%nStress < 1) extmsg = trim(extmsg)//' nStress' @@ -615,13 +615,13 @@ end subroutine crystallite_orientations !-------------------------------------------------------------------------------------------------- function crystallite_push33ToRef(co,ce, tensor33) - real(pReal), dimension(3,3), intent(in) :: tensor33 + real(pREAL), dimension(3,3), intent(in) :: tensor33 integer, intent(in):: & co, & ce - real(pReal), dimension(3,3) :: crystallite_push33ToRef + real(pREAL), dimension(3,3) :: crystallite_push33ToRef - real(pReal), dimension(3,3) :: T + real(pREAL), dimension(3,3) :: T integer :: ph, en @@ -639,9 +639,9 @@ end function crystallite_push33ToRef !-------------------------------------------------------------------------------------------------- logical pure function converged(residuum,state,atol) - real(pReal), intent(in), dimension(:) ::& + real(pREAL), intent(in), dimension(:) ::& residuum, state, atol - real(pReal) :: & + real(pREAL) :: & rTol rTol = num%rTol_crystalliteState diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index 43e39a980..7b27cf366 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -4,9 +4,9 @@ submodule(phase) damage type :: tDamageParameters - real(pReal) :: & - mu = 0.0_pReal, & !< viscosity - l_c = 0.0_pReal !< characteristic length + real(pREAL) :: & + mu = 0.0_pREAL, & !< viscosity + l_c = 0.0_pREAL !< characteristic length end type tDamageParameters enum, bind(c); enumerator :: & @@ -19,7 +19,7 @@ submodule(phase) damage type :: tDataContainer - real(pReal), dimension(:), allocatable :: phi + real(pREAL), dimension(:), allocatable :: phi end type tDataContainer integer(kind(DAMAGE_UNDEFINED_ID)), dimension(:), allocatable :: & @@ -42,16 +42,16 @@ submodule(phase) damage module subroutine isobrittle_deltaState(C, Fe, ph, en) integer, intent(in) :: ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fe - real(pReal), intent(in), dimension(6,6) :: & + real(pREAL), intent(in), dimension(6,6) :: & C end subroutine isobrittle_deltaState module subroutine anisobrittle_dotState(M_i, ph, en) integer, intent(in) :: ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & M_i end subroutine anisobrittle_dotState @@ -99,7 +99,7 @@ module subroutine damage_init() Nmembers = count(material_ID_phase == ph) - allocate(current(ph)%phi(Nmembers),source=1.0_pReal) + allocate(current(ph)%phi(Nmembers),source=1.0_pREAL) phase => phases%get_dict(ph) source => phase%get_dict('damage',defaultVal=emptyDict) @@ -131,7 +131,7 @@ end subroutine damage_init !-------------------------------------------------------------------------------------------------- module function phase_damage_constitutive(Delta_t,co,ce) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & co, & ce @@ -154,9 +154,9 @@ end function phase_damage_constitutive !-------------------------------------------------------------------------------------------------- module function phase_damage_C66(C66,ph,en) result(C66_degraded) - real(pReal), dimension(6,6), intent(in) :: C66 + real(pREAL), dimension(6,6), intent(in) :: C66 integer, intent(in) :: ph,en - real(pReal), dimension(6,6) :: C66_degraded + real(pREAL), dimension(6,6) :: C66_degraded damageType: select case (phase_damage(ph)) @@ -195,9 +195,9 @@ end subroutine damage_restore module function phase_f_phi(phi,co,ce) result(f) integer, intent(in) :: ce,co - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & phi !< damage parameter - real(pReal) :: & + real(pREAL) :: & f integer :: & @@ -209,10 +209,10 @@ module function phase_f_phi(phi,co,ce) result(f) select case(phase_damage(ph)) case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID) - f = 1.0_pReal & + f = 1.0_pREAL & - phi*damageState(ph)%state(1,en) case default - f = 0.0_pReal + f = 0.0_pREAL end select end function phase_f_phi @@ -224,7 +224,7 @@ end function phase_f_phi !-------------------------------------------------------------------------------------------------- function integrateDamageState(Delta_t,ph,en) result(broken) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & ph, & en @@ -233,11 +233,11 @@ function integrateDamageState(Delta_t,ph,en) result(broken) integer :: & NiterationState, & !< number of iterations in state loop size_so - real(pReal) :: & + real(pREAL) :: & zeta - real(pReal), dimension(phase_damage_maxSizeDotState) :: & + real(pREAL), dimension(phase_damage_maxSizeDotState) :: & r ! state residuum - real(pReal), dimension(phase_damage_maxSizeDotState,2) :: source_dotState + real(pREAL), dimension(phase_damage_maxSizeDotState,2) :: source_dotState logical :: & converged_ @@ -254,7 +254,7 @@ function integrateDamageState(Delta_t,ph,en) result(broken) size_so = damageState(ph)%sizeDotState damageState(ph)%state(1:size_so,en) = damageState(ph)%state0 (1:size_so,en) & + damageState(ph)%dotState(1:size_so,en) * Delta_t - source_dotState(1:size_so,2) = 0.0_pReal + source_dotState(1:size_so,2) = 0.0_pREAL iteration: do NiterationState = 1, num%nState @@ -267,7 +267,7 @@ function integrateDamageState(Delta_t,ph,en) result(broken) zeta = damper(damageState(ph)%dotState(:,en),source_dotState(1:size_so,1),source_dotState(1:size_so,2)) damageState(ph)%dotState(:,en) = damageState(ph)%dotState(:,en) * zeta & - + source_dotState(1:size_so,1)* (1.0_pReal - zeta) + + source_dotState(1:size_so,1)* (1.0_pREAL - zeta) r(1:size_so) = damageState(ph)%state (1:size_so,en) & - damageState(ph)%State0 (1:size_so,en) & - damageState(ph)%dotState(1:size_so,en) * Delta_t @@ -291,20 +291,20 @@ function integrateDamageState(Delta_t,ph,en) result(broken) !-------------------------------------------------------------------------------------------------- !> @brief Calculate the damping for correction of state and dot state. !-------------------------------------------------------------------------------------------------- - real(pReal) pure function damper(omega_0,omega_1,omega_2) + real(pREAL) pure function damper(omega_0,omega_1,omega_2) - real(pReal), dimension(:), intent(in) :: & + real(pREAL), dimension(:), intent(in) :: & omega_0, omega_1, omega_2 - real(pReal) :: dot_prod12, dot_prod22 + real(pREAL) :: dot_prod12, dot_prod22 dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2) dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2) - if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pReal .and. dot_prod22 > 0.0_pReal) then - damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pREAL .and. dot_prod22 > 0.0_pREAL) then + damper = 0.75_pREAL + 0.25_pREAL * tanh(2.0_pREAL + 4.0_pREAL * dot_prod12 / dot_prod22) else - damper = 1.0_pReal + damper = 1.0_pREAL end if end function damper @@ -401,7 +401,7 @@ end function phase_damage_collectDotState module function phase_mu_phi(co,ce) result(mu) integer, intent(in) :: co, ce - real(pReal) :: mu + real(pREAL) :: mu mu = param(material_ID_phase(co,ce))%mu @@ -415,7 +415,7 @@ end function phase_mu_phi module function phase_K_phi(co,ce) result(K) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%l_c**2*math_I3) @@ -432,7 +432,7 @@ function phase_damage_deltaState(Fe, ph, en) result(broken) integer, intent(in) :: & ph, & en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fe !< elastic deformation gradient integer :: & @@ -496,7 +496,7 @@ end function source_active !---------------------------------------------------------------------------------------------- module subroutine phase_set_phi(phi,co,ce) - real(pReal), intent(in) :: phi + real(pREAL), intent(in) :: phi integer, intent(in) :: ce, co @@ -508,7 +508,7 @@ end subroutine phase_set_phi module function damage_phi(ph,en) result(phi) integer, intent(in) :: ph, en - real(pReal) :: phi + real(pREAL) :: phi phi = current(ph)%phi(en) diff --git a/src/phase_damage_anisobrittle.f90 b/src/phase_damage_anisobrittle.f90 index 4c1148b79..788b8292c 100644 --- a/src/phase_damage_anisobrittle.f90 +++ b/src/phase_damage_anisobrittle.f90 @@ -7,13 +7,13 @@ submodule (phase:damage) anisobrittle type :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & + real(pREAL) :: & dot_o_0, & !< opening rate of cleavage planes p !< damage rate sensitivity - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & s_crit, & !< critical displacement g_crit !< critical load - real(pReal), dimension(:,:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:,:), allocatable :: & cleavage_systems integer :: & sum_N_cl !< total number of cleavage planes @@ -90,15 +90,15 @@ module function anisobrittle_init() result(mySources) #endif ! sanity checks - if (prm%p <= 0.0_pReal) extmsg = trim(extmsg)//' p' - if (prm%dot_o_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_o_0' - if (any(prm%g_crit < 0.0_pReal)) extmsg = trim(extmsg)//' g_crit' - if (any(prm%s_crit < 0.0_pReal)) extmsg = trim(extmsg)//' s_crit' + if (prm%p <= 0.0_pREAL) extmsg = trim(extmsg)//' p' + if (prm%dot_o_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_o_0' + if (any(prm%g_crit < 0.0_pREAL)) extmsg = trim(extmsg)//' g_crit' + if (any(prm%s_crit < 0.0_pREAL)) extmsg = trim(extmsg)//' s_crit' Nmembers = count(material_ID_phase==ph) call phase_allocateState(damageState(ph),Nmembers,1,1,0) - damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) - if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' + damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pREAL) + if (any(damageState(ph)%atol < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_phi' end associate @@ -117,17 +117,17 @@ module subroutine anisobrittle_dotState(M_i, ph,en) integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & M_i integer :: & a, i - real(pReal) :: & + real(pREAL) :: & traction, traction_crit associate(prm => param(ph)) - damageState(ph)%dotState(1,en) = 0.0_pReal + damageState(ph)%dotState(1,en) = 0.0_pREAL do a = 1, prm%sum_N_cl traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a) do i = 1,3 @@ -135,7 +135,7 @@ module subroutine anisobrittle_dotState(M_i, ph,en) damageState(ph)%dotState(1,en) = damageState(ph)%dotState(1,en) & + prm%dot_o_0 / prm%s_crit(a) & - * (max(0.0_pReal, abs(traction) - traction_crit)/traction_crit)**prm%p + * (max(0.0_pREAL, abs(traction) - traction_crit)/traction_crit)**prm%p end do end do end associate @@ -173,22 +173,22 @@ module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & M_i - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & L_i !< damage velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dL_i_dM_i !< derivative of L_i with respect to M_i integer :: & a, k, l, m, n, i - real(pReal) :: & + real(pREAL) :: & traction, traction_crit, & udot, dudot_dt - L_i = 0.0_pReal - dL_i_dM_i = 0.0_pReal + L_i = 0.0_pREAL + dL_i_dM_i = 0.0_pREAL associate(prm => param(ph)) do a = 1,prm%sum_N_cl traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a) @@ -196,9 +196,9 @@ module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en do i = 1, 3 traction = math_tensordot(M_i,prm%cleavage_systems(1:3,1:3,i,a)) if (abs(traction) > traction_crit + tol_math_check) then - udot = sign(1.0_pReal,traction)* prm%dot_o_0 * ((abs(traction) - traction_crit)/traction_crit)**prm%p + udot = sign(1.0_pREAL,traction)* prm%dot_o_0 * ((abs(traction) - traction_crit)/traction_crit)**prm%p L_i = L_i + udot*prm%cleavage_systems(1:3,1:3,i,a) - dudot_dt = sign(1.0_pReal,traction)*udot*prm%p / (abs(traction) - traction_crit) + dudot_dt = sign(1.0_pREAL,traction)*udot*prm%p / (abs(traction) - traction_crit) forall (k=1:3,l=1:3,m=1:3,n=1:3) & dL_i_dM_i(k,l,m,n) = dL_i_dM_i(k,l,m,n) & + dudot_dt*prm%cleavage_systems(k,l,i,a) * prm%cleavage_systems(m,n,i,a) diff --git a/src/phase_damage_isobrittle.f90 b/src/phase_damage_isobrittle.f90 index fcc8393b9..2efff9f7d 100644 --- a/src/phase_damage_isobrittle.f90 +++ b/src/phase_damage_isobrittle.f90 @@ -7,14 +7,14 @@ submodule(phase:damage) isobrittle type :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & + real(pREAL) :: & W_crit !< critical elastic strain energy character(len=pSTRLEN), allocatable, dimension(:) :: & output end type tParameters type :: tIsobrittleState - real(pReal), pointer, dimension(:) :: & !< vectors along Nmembers + real(pREAL), pointer, dimension(:) :: & !< vectors along Nmembers r_W !< ratio between actual and critical strain energy density end type tIsobrittleState @@ -77,12 +77,12 @@ module function isobrittle_init() result(mySources) #endif ! sanity checks - if (prm%W_crit <= 0.0_pReal) extmsg = trim(extmsg)//' W_crit' + if (prm%W_crit <= 0.0_pREAL) extmsg = trim(extmsg)//' W_crit' Nmembers = count(material_ID_phase==ph) call phase_allocateState(damageState(ph),Nmembers,1,0,1) - damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) - if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' + damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pREAL) + if (any(damageState(ph)%atol < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_phi' stt%r_W => damageState(ph)%state(1,:) dlt%r_W => damageState(ph)%deltaState(1,:) @@ -105,23 +105,23 @@ end function isobrittle_init module subroutine isobrittle_deltaState(C, Fe, ph,en) integer, intent(in) :: ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fe - real(pReal), intent(in), dimension(6,6) :: & + real(pREAL), intent(in), dimension(6,6) :: & C - real(pReal), dimension(6) :: & + real(pREAL), dimension(6) :: & epsilon - real(pReal) :: & + real(pREAL) :: & r_W - epsilon = math_33toVoigt6_strain(0.5_pReal*(matmul(transpose(Fe),Fe)-math_I3)) + epsilon = math_33toVoigt6_strain(0.5_pREAL*(matmul(transpose(Fe),Fe)-math_I3)) associate(prm => param(ph), stt => state(ph), dlt => deltaState(ph)) - r_W = (0.5_pReal*dot_product(epsilon,matmul(C,epsilon)))/prm%W_crit - dlt%r_W(en) = merge(r_W - stt%r_W(en), 0.0_pReal, r_W > stt%r_W(en)) + r_W = (0.5_pREAL*dot_product(epsilon,matmul(C,epsilon)))/prm%W_crit + dlt%r_W(en) = merge(r_W - stt%r_W(en), 0.0_pREAL, r_W > stt%r_W(en)) end associate diff --git a/src/phase_mechanical.f90 b/src/phase_mechanical.f90 index 4df932650..0f931517a 100644 --- a/src/phase_mechanical.f90 +++ b/src/phase_mechanical.f90 @@ -57,22 +57,22 @@ submodule(phase) mechanical integer, intent(in) :: & ph, & en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fe, & !< elastic deformation gradient Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient end subroutine phase_hooke_SandItsTangents module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Li !< inleastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLi_dMi !< derivative of Li with respect to Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mi !< Mandel stress integer, intent(in) :: & ph, & @@ -83,9 +83,9 @@ submodule(phase) mechanical integer, intent(in) :: & ph, & en - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & subdt !< timestep - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function plastic_dotState @@ -101,13 +101,13 @@ submodule(phase) mechanical S, Fi, ph,en) integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & S !< 2nd Piola-Kirchhoff stress - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Li !< intermediate velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLi_dS, & !< derivative of Li with respect to S dLi_dFi @@ -118,12 +118,12 @@ submodule(phase) mechanical S, Fi, ph,en) integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & S, & !< 2nd Piola-Kirchhoff stress Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Lp !< plastic velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLp_dS, & dLp_dFi !< derivative of Lp with respect to Fi end subroutine plastic_LpAndItsTangents @@ -160,23 +160,23 @@ submodule(phase) mechanical end subroutine plastic_nonlocal_result module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC) - real(pReal), dimension(6,6) :: homogenizedC + real(pREAL), dimension(6,6) :: homogenizedC integer, intent(in) :: ph,en end function plastic_dislotwin_homogenizedC pure module function elastic_C66(ph,en) result(C66) - real(pReal), dimension(6,6) :: C66 + real(pREAL), dimension(6,6) :: C66 integer, intent(in) :: ph, en end function elastic_C66 pure module function elastic_mu(ph,en,isotropic_bound) result(mu) - real(pReal) :: mu + real(pREAL) :: mu integer, intent(in) :: ph, en character(len=*), intent(in) :: isotropic_bound end function elastic_mu pure module function elastic_nu(ph,en,isotropic_bound) result(nu) - real(pReal) :: nu + real(pREAL) :: nu integer, intent(in) :: ph, en character(len=*), intent(in) :: isotropic_bound end function elastic_nu @@ -243,13 +243,13 @@ module subroutine mechanical_init(phases) allocate(phase_mechanical_Fi(ph)%data(3,3,Nmembers)) allocate(phase_mechanical_Fp(ph)%data(3,3,Nmembers)) allocate(phase_mechanical_F(ph)%data(3,3,Nmembers)) - allocate(phase_mechanical_Li(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_Li0(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_Lp(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_Lp0(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_S(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_P(ph)%data(3,3,Nmembers),source=0.0_pReal) - allocate(phase_mechanical_S0(ph)%data(3,3,Nmembers),source=0.0_pReal) + allocate(phase_mechanical_Li(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_Li0(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_Lp(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_Lp0(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_S(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_P(ph)%data(3,3,Nmembers),source=0.0_pREAL) + allocate(phase_mechanical_S0(ph)%data(3,3,Nmembers),source=0.0_pREAL) phase => phases%get_dict(ph) mech => phase%get_dict('mechanical') @@ -359,11 +359,11 @@ end subroutine mechanical_result !-------------------------------------------------------------------------------------------------- function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) - real(pReal), dimension(3,3), intent(in) :: F,subFp0,subFi0 - real(pReal), intent(in) :: Delta_t + real(pREAL), dimension(3,3), intent(in) :: F,subFp0,subFi0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en - real(pReal), dimension(3,3):: Fp_new, & ! plastic deformation gradient at end of timestep + real(pREAL), dimension(3,3):: Fp_new, & ! plastic deformation gradient at end of timestep invFp_new, & ! inverse of Fp_new invFp_current, & ! inverse of Fp_current Lpguess, & ! current guess for plastic velocity gradient @@ -386,11 +386,11 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) A, & B, & temp_33 - real(pReal), dimension(9) :: temp_9 ! needed for matrix inversion by LAPACK + real(pREAL), dimension(9) :: temp_9 ! needed for matrix inversion by LAPACK integer, dimension(9) :: devNull_9 ! needed for matrix inversion by LAPACK - real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) + real(pREAL), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme) - real(pReal), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress + real(pREAL), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress dS_dFi, & dFe_dLp, & ! partial derivative of elastic deformation gradient dFe_dLi, & @@ -399,7 +399,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) dLi_dFi, & dLp_dS, & dLi_dS - real(pReal) steplengthLp, & + real(pREAL) steplengthLp, & steplengthLi, & atol_Lp, & atol_Li @@ -427,8 +427,8 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) A = matmul(F,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp jacoCounterLi = 0 - steplengthLi = 1.0_pReal - residuumLi_old = 0.0_pReal + steplengthLi = 1.0_pREAL + residuumLi_old = 0.0_pREAL Liguess_old = Liguess NiterationStressLi = 0 @@ -440,8 +440,8 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) Fi_new = math_inv33(invFi_new) jacoCounterLp = 0 - steplengthLp = 1.0_pReal - residuumLp_old = 0.0_pReal + steplengthLp = 1.0_pREAL + residuumLp_old = 0.0_pREAL Lpguess_old = Lpguess NiterationStressLp = 0 @@ -469,7 +469,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) elseif (NiterationStressLp == 1 .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... residuumLp_old = residuumLp ! ...remember old values and... Lpguess_old = Lpguess - steplengthLp = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) + steplengthLp = 1.0_pREAL ! ...proceed with normal step length (calculate new search direction) else ! not converged and residuum not improved... steplengthLp = num%subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction Lpguess = Lpguess_old & @@ -509,7 +509,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) elseif (NiterationStressLi == 1 .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... residuumLi_old = residuumLi ! ...remember old values and... Liguess_old = Liguess - steplengthLi = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) + steplengthLi = 1.0_pREAL ! ...proceed with normal step length (calculate new search direction) else ! not converged and residuum not improved... steplengthLi = num%subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction Liguess = Liguess_old & @@ -550,7 +550,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) phase_mechanical_S(ph)%data(1:3,1:3,en) = S phase_mechanical_Lp(ph)%data(1:3,1:3,en) = Lpguess phase_mechanical_Li(ph)%data(1:3,1:3,en) = Liguess - phase_mechanical_Fp(ph)%data(1:3,1:3,en) = Fp_new / math_det33(Fp_new)**(1.0_pReal/3.0_pReal) ! regularize + phase_mechanical_Fp(ph)%data(1:3,1:3,en) = Fp_new / math_det33(Fp_new)**(1.0_pREAL/3.0_pREAL) ! regularize phase_mechanical_Fi(ph)%data(1:3,1:3,en) = Fi_new phase_mechanical_Fe(ph)%data(1:3,1:3,en) = matmul(matmul(F,invFp_new),invFi_new) broken = .false. @@ -564,9 +564,9 @@ end function integrateStress !-------------------------------------------------------------------------------------------------- function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & ph, & en @@ -576,12 +576,12 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b integer :: & NiterationState, & !< number of iterations in state loop sizeDotState - real(pReal) :: & + real(pREAL) :: & zeta - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & r, & ! state residuum dotState - real(pReal), dimension(plasticState(ph)%sizeDotState,2) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState,2) :: & dotState_last @@ -595,7 +595,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b iteration: do NiterationState = 1, num%nState - dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0_pReal, nIterationState > 1) + dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0_pREAL, nIterationState > 1) dotState_last(1:sizeDotState,1) = dotState broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) @@ -606,7 +606,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b zeta = damper(dotState,dotState_last(1:sizeDotState,1),dotState_last(1:sizeDotState,2)) dotState = dotState * zeta & - + dotState_last(1:sizeDotState,1) * (1.0_pReal - zeta) + + dotState_last(1:sizeDotState,1) * (1.0_pREAL - zeta) r = plasticState(ph)%state(1:sizeDotState,en) & - subState0 & - dotState * Delta_t @@ -625,21 +625,21 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b !-------------------------------------------------------------------------------------------------- !> @brief calculate the damping for correction of state and dot state !-------------------------------------------------------------------------------------------------- - real(pReal) pure function damper(omega_0,omega_1,omega_2) + real(pREAL) pure function damper(omega_0,omega_1,omega_2) - real(pReal), dimension(:), intent(in) :: & + real(pREAL), dimension(:), intent(in) :: & omega_0, omega_1, omega_2 - real(pReal) :: dot_prod12, dot_prod22 + real(pREAL) :: dot_prod12, dot_prod22 dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2) dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2) - if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pReal .and. dot_prod22 > 0.0_pReal) then - damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pREAL .and. dot_prod22 > 0.0_pREAL) then + damper = 0.75_pREAL + 0.25_pREAL * tanh(2.0_pREAL + 4.0_pREAL * dot_prod12 / dot_prod22) else - damper = 1.0_pReal + damper = 1.0_pREAL end if end function damper @@ -652,16 +652,16 @@ end function integrateStateFPI !-------------------------------------------------------------------------------------------------- function integrateStateEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & ph, & en !< grain index in grain loop logical :: & broken - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState integer :: & sizeDotState @@ -692,9 +692,9 @@ end function integrateStateEuler !-------------------------------------------------------------------------------------------------- function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & ph, & en @@ -703,7 +703,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en integer :: & sizeDotState - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & r, & dotState @@ -715,7 +715,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en sizeDotState = plasticState(ph)%sizeDotState - r = - dotState * 0.5_pReal * Delta_t + r = - dotState * 0.5_pREAL * Delta_t #ifndef __INTEL_LLVM_COMPILER plasticState(ph)%state(1:sizeDotState,en) = subState0 + dotState*Delta_t #else @@ -731,7 +731,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en dotState = plastic_dotState(Delta_t,ph,en) if (any(IEEE_is_NaN(dotState))) return - broken = .not. converged(r + 0.5_pReal * dotState * Delta_t, & + broken = .not. converged(r + 0.5_pREAL * dotState * Delta_t, & plasticState(ph)%state(1:sizeDotState,en), & plasticState(ph)%atol(1:sizeDotState)) @@ -743,22 +743,22 @@ end function integrateStateAdaptiveEuler !--------------------------------------------------------------------------------------------------- function integrateStateRK4(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en logical :: broken - real(pReal), dimension(3,3), parameter :: & + real(pREAL), dimension(3,3), parameter :: & A = reshape([& - 0.5_pReal, 0.0_pReal, 0.0_pReal, & - 0.0_pReal, 0.5_pReal, 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal],& + 0.5_pREAL, 0.0_pREAL, 0.0_pREAL, & + 0.0_pREAL, 0.5_pREAL, 0.0_pREAL, & + 0.0_pREAL, 0.0_pREAL, 1.0_pREAL],& shape(A)) - real(pReal), dimension(3), parameter :: & - C = [0.5_pReal, 0.5_pReal, 1.0_pReal] - real(pReal), dimension(4), parameter :: & - B = [6.0_pReal, 3.0_pReal, 3.0_pReal, 6.0_pReal]**(-1) + real(pREAL), dimension(3), parameter :: & + C = [0.5_pREAL, 0.5_pREAL, 1.0_pREAL] + real(pREAL), dimension(4), parameter :: & + B = [6.0_pREAL, 3.0_pREAL, 3.0_pREAL, 6.0_pREAL]**(-1) broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C) @@ -771,29 +771,29 @@ end function integrateStateRK4 !--------------------------------------------------------------------------------------------------- function integrateStateRKCK45(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en logical :: broken - real(pReal), dimension(5,5), parameter :: & + real(pREAL), dimension(5,5), parameter :: & A = reshape([& - 1._pReal/5._pReal, .0_pReal, .0_pReal, .0_pReal, .0_pReal, & - 3._pReal/40._pReal, 9._pReal/40._pReal, .0_pReal, .0_pReal, .0_pReal, & - 3_pReal/10._pReal, -9._pReal/10._pReal, 6._pReal/5._pReal, .0_pReal, .0_pReal, & - -11._pReal/54._pReal, 5._pReal/2._pReal, -70.0_pReal/27.0_pReal, 35.0_pReal/27.0_pReal, .0_pReal, & - 1631._pReal/55296._pReal,175._pReal/512._pReal,575._pReal/13824._pReal,44275._pReal/110592._pReal,253._pReal/4096._pReal],& + 1._pREAL/5._pREAL, .0_pREAL, .0_pREAL, .0_pREAL, .0_pREAL, & + 3._pREAL/40._pREAL, 9._pREAL/40._pREAL, .0_pREAL, .0_pREAL, .0_pREAL, & + 3_pREAL/10._pREAL, -9._pREAL/10._pREAL, 6._pREAL/5._pREAL, .0_pREAL, .0_pREAL, & + -11._pREAL/54._pREAL, 5._pREAL/2._pREAL, -70.0_pREAL/27.0_pREAL, 35.0_pREAL/27.0_pREAL, .0_pREAL, & + 1631._pREAL/55296._pREAL,175._pREAL/512._pREAL,575._pREAL/13824._pREAL,44275._pREAL/110592._pREAL,253._pREAL/4096._pREAL],& shape(A)) - real(pReal), dimension(5), parameter :: & - C = [0.2_pReal, 0.3_pReal, 0.6_pReal, 1.0_pReal, 0.875_pReal] - real(pReal), dimension(6), parameter :: & + real(pREAL), dimension(5), parameter :: & + C = [0.2_pREAL, 0.3_pREAL, 0.6_pREAL, 1.0_pREAL, 0.875_pREAL] + real(pREAL), dimension(6), parameter :: & B = & - [37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, & - 125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], & + [37.0_pREAL/378.0_pREAL, .0_pREAL, 250.0_pREAL/621.0_pREAL, & + 125.0_pREAL/594.0_pREAL, .0_pREAL, 512.0_pREAL/1771.0_pREAL], & DB = B - & - [2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,& - 13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 1._pReal/4._pReal] + [2825.0_pREAL/27648.0_pREAL, .0_pREAL, 18575.0_pREAL/48384.0_pREAL,& + 13525.0_pREAL/55296.0_pREAL, 277.0_pREAL/14336.0_pREAL, 1._pREAL/4._pREAL] broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) @@ -807,12 +807,12 @@ end function integrateStateRKCK45 !-------------------------------------------------------------------------------------------------- function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) result(broken) - real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 - real(pReal), intent(in),dimension(:) :: subState0 - real(pReal), intent(in) :: Delta_t - real(pReal), dimension(:,:), intent(in) :: A - real(pReal), dimension(:), intent(in) :: B, C - real(pReal), dimension(:), intent(in), optional :: DB + real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 + real(pREAL), intent(in),dimension(:) :: subState0 + real(pREAL), intent(in) :: Delta_t + real(pREAL), dimension(:,:), intent(in) :: A + real(pREAL), dimension(:), intent(in) :: B, C + real(pREAL), dimension(:), intent(in), optional :: DB integer, intent(in) :: & ph, & en @@ -822,9 +822,9 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) stage, & ! stage index in integration stage loop n, & sizeDotState - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState - real(pReal), dimension(plasticState(ph)%sizeDotState,size(B)) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState,size(B)) :: & plastic_RKdotState @@ -945,7 +945,7 @@ subroutine results(group,ph) function to_quaternion(dataset) type(tRotation), dimension(:), intent(in) :: dataset - real(pReal), dimension(4,size(dataset,1)) :: to_quaternion + real(pREAL), dimension(4,size(dataset,1)) :: to_quaternion integer :: i @@ -986,26 +986,26 @@ end subroutine mechanical_forward !-------------------------------------------------------------------------------------------------- module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & co, & ce logical :: converged_ - real(pReal) :: & + real(pREAL) :: & formerSubStep integer :: & ph, en, sizeDotState logical :: todo - real(pReal) :: subFrac,subStep - real(pReal), dimension(3,3) :: & + real(pREAL) :: subFrac,subStep + real(pREAL), dimension(3,3) :: & subFp0, & subFi0, & subLp0, & subLi0, & subF0, & subF - real(pReal), dimension(plasticState(material_ID_phase(co,ce))%sizeState) :: subState0 + real(pREAL), dimension(plasticState(material_ID_phase(co,ce))%sizeState) :: subState0 ph = material_ID_phase(co,ce) @@ -1017,9 +1017,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) subFp0 = phase_mechanical_Fp0(ph)%data(1:3,1:3,en) subFi0 = phase_mechanical_Fi0(ph)%data(1:3,1:3,en) subF0 = phase_mechanical_F0(ph)%data(1:3,1:3,en) - subFrac = 0.0_pReal + subFrac = 0.0_pREAL todo = .true. - subStep = 1.0_pReal/num%subStepSizeCryst + subStep = 1.0_pREAL/num%subStepSizeCryst converged_ = .false. ! pretend failed step of 1/subStepSizeCryst todo = .true. @@ -1028,9 +1028,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) if (converged_) then formerSubStep = subStep subFrac = subFrac + subStep - subStep = min(1.0_pReal - subFrac, num%stepIncreaseCryst * subStep) + subStep = min(1.0_pREAL - subFrac, num%stepIncreaseCryst * subStep) - todo = subStep > 0.0_pReal ! still time left to integrate on? + todo = subStep > 0.0_pREAL ! still time left to integrate on? if (todo) then subF0 = subF @@ -1047,7 +1047,7 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) phase_mechanical_Fp(ph)%data(1:3,1:3,en) = subFp0 phase_mechanical_Fi(ph)%data(1:3,1:3,en) = subFi0 phase_mechanical_S(ph)%data(1:3,1:3,en) = phase_mechanical_S0(ph)%data(1:3,1:3,en) - if (subStep < 1.0_pReal) then ! actual (not initial) cutback + if (subStep < 1.0_pREAL) then ! actual (not initial) cutback phase_mechanical_Lp(ph)%data(1:3,1:3,en) = subLp0 phase_mechanical_Li(ph)%data(1:3,1:3,en) = subLi0 end if @@ -1105,19 +1105,19 @@ end subroutine mechanical_restore !-------------------------------------------------------------------------------------------------- module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: & co, & !< counter in constituent loop ce - real(pReal), dimension(3,3,3,3) :: dPdF + real(pREAL), dimension(3,3,3,3) :: dPdF integer :: & o, & p, ph, en - real(pReal), dimension(3,3) :: devNull, & + real(pREAL), dimension(3,3) :: devNull, & invSubFp0,invSubFi0,invFp,invFi, & temp_33_1, temp_33_2, temp_33_3 - real(pReal), dimension(3,3,3,3) :: dSdFe, & + real(pREAL), dimension(3,3,3,3) :: dSdFe, & dSdF, & dSdFi, & dLidS, & ! tangent in lattice configuration @@ -1129,7 +1129,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) rhs_3333, & lhs_3333, & temp_3333 - real(pReal), dimension(9,9):: temp_99 + real(pREAL), dimension(9,9):: temp_99 logical :: error @@ -1150,9 +1150,9 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) invSubFi0 = math_inv33(phase_mechanical_Fi0(ph)%data(1:3,1:3,en)) if (sum(abs(dLidS)) < tol_math_check) then - dFidS = 0.0_pReal + dFidS = 0.0_pREAL else - lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal + lhs_3333 = 0.0_pREAL; rhs_3333 = 0.0_pREAL do o=1,3; do p=1,3 #ifndef __INTEL_LLVM_COMPILER lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & @@ -1171,7 +1171,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) if (error) then call IO_warning(600,'inversion error in analytic tangent calculation', & label1='phase',ID1=ph,label2='entry',ID2=en) - dFidS = 0.0_pReal + dFidS = 0.0_pREAL else dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) end if @@ -1223,7 +1223,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) temp_33_2 = matmul(phase_mechanical_F(ph)%data(1:3,1:3,en),invFp) temp_33_3 = matmul(temp_33_2,phase_mechanical_S(ph)%data(1:3,1:3,en)) - dPdF = 0.0_pReal + dPdF = 0.0_pREAL do p=1,3 dPdF(p,1:3,p,1:3) = transpose(matmul(invFp,temp_33_1)) end do @@ -1283,7 +1283,7 @@ end subroutine mechanical_restartRead module function mechanical_S(ph,en) result(S) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: S + real(pREAL), dimension(3,3) :: S S = phase_mechanical_S(ph)%data(1:3,1:3,en) @@ -1297,7 +1297,7 @@ end function mechanical_S module function mechanical_L_p(ph,en) result(L_p) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: L_p + real(pREAL), dimension(3,3) :: L_p L_p = phase_mechanical_Lp(ph)%data(1:3,1:3,en) @@ -1311,7 +1311,7 @@ end function mechanical_L_p module function mechanical_F_e(ph,en) result(F_e) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: F_e + real(pREAL), dimension(3,3) :: F_e F_e = phase_mechanical_Fe(ph)%data(1:3,1:3,en) @@ -1325,7 +1325,7 @@ end function mechanical_F_e module function mechanical_F_i(ph,en) result(F_i) integer, intent(in) :: ph,en - real(pReal), dimension(3,3) :: F_i + real(pREAL), dimension(3,3) :: F_i F_i = phase_mechanical_Fi(ph)%data(1:3,1:3,en) @@ -1339,7 +1339,7 @@ end function mechanical_F_i module function phase_P(co,ce) result(P) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: P + real(pREAL), dimension(3,3) :: P P = phase_mechanical_P(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce)) @@ -1353,7 +1353,7 @@ end function phase_P module function phase_F(co,ce) result(F) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: F + real(pREAL), dimension(3,3) :: F F = phase_mechanical_F(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce)) @@ -1366,7 +1366,7 @@ end function phase_F !-------------------------------------------------------------------------------------------------- module subroutine phase_set_F(F,co,ce) - real(pReal), dimension(3,3), intent(in) :: F + real(pREAL), dimension(3,3), intent(in) :: F integer, intent(in) :: co, ce diff --git a/src/phase_mechanical_eigen.f90 b/src/phase_mechanical_eigen.f90 index bf45a2468..ec1bcfbbc 100644 --- a/src/phase_mechanical_eigen.f90 +++ b/src/phase_mechanical_eigen.f90 @@ -20,9 +20,9 @@ submodule(phase:mechanical) eigen module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me) integer, intent(in) :: ph, me - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Li !< thermal velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero) end subroutine thermalexpansion_LiAndItsTangent @@ -145,32 +145,32 @@ module subroutine phase_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & S !< 2nd Piola-Kirchhoff stress - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Li !< intermediate velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLi_dS, & !< derivative of Li with respect to S dLi_dFi - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & my_Li, & !< intermediate velocity gradient FiInv, & temp_33 - real(pReal), dimension(3,3,3,3) :: & + real(pREAL), dimension(3,3,3,3) :: & my_dLi_dS - real(pReal) :: & + real(pREAL) :: & detFi integer :: & k, i, j logical :: active active = .false. - Li = 0.0_pReal - dLi_dS = 0.0_pReal - dLi_dFi = 0.0_pReal + Li = 0.0_pREAL + dLi_dS = 0.0_pREAL + dLi_dFi = 0.0_pREAL plasticType: select case (phase_plasticity(ph)) diff --git a/src/phase_mechanical_eigen_thermalexpansion.f90 b/src/phase_mechanical_eigen_thermalexpansion.f90 index 23c6b0aee..75a2ae0d0 100644 --- a/src/phase_mechanical_eigen_thermalexpansion.f90 +++ b/src/phase_mechanical_eigen_thermalexpansion.f90 @@ -75,13 +75,13 @@ end function thermalexpansion_init module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me) integer, intent(in) :: ph, me - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Li !< thermal velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero) - real(pReal) :: T, dot_T - real(pReal), dimension(3,3) :: Alpha + real(pREAL) :: T, dot_T + real(pREAL), dimension(3,3) :: Alpha T = thermal_T(ph,me) @@ -89,14 +89,14 @@ module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me) associate(prm => param(kinematics_thermal_expansion_instance(ph))) - Alpha = 0.0_pReal + Alpha = 0.0_pREAL Alpha(1,1) = prm%Alpha_11%at(T) if (any(phase_lattice(ph) == ['hP','tI'])) Alpha(3,3) = prm%Alpha_33%at(T) Alpha = lattice_symmetrize_33(Alpha,phase_lattice(ph)) Li = dot_T * Alpha end associate - dLi_dTstar = 0.0_pReal + dLi_dTstar = 0.0_pREAL end subroutine thermalexpansion_LiAndItsTangent diff --git a/src/phase_mechanical_elastic.f90 b/src/phase_mechanical_elastic.f90 index 9adcec823..75a8753a5 100644 --- a/src/phase_mechanical_elastic.f90 +++ b/src/phase_mechanical_elastic.f90 @@ -77,13 +77,13 @@ pure module function elastic_C66(ph,en) result(C66) ph, & en - real(pReal), dimension(6,6) :: C66 - real(pReal) :: T + real(pREAL), dimension(6,6) :: C66 + real(pREAL) :: T associate(prm => param(ph)) - C66 = 0.0_pReal + C66 = 0.0_pREAL T = thermal_T(ph,en) C66(1,1) = prm%C_11%at(T) @@ -113,7 +113,7 @@ pure module function elastic_mu(ph,en,isotropic_bound) result(mu) ph, & en character(len=*), intent(in) :: isotropic_bound - real(pReal) :: & + real(pREAL) :: & mu @@ -135,7 +135,7 @@ pure module function elastic_nu(ph,en,isotropic_bound) result(nu) ph, & en character(len=*), intent(in) :: isotropic_bound - real(pReal) :: & + real(pREAL) :: & nu @@ -160,18 +160,18 @@ module subroutine phase_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & integer, intent(in) :: & ph, & en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & Fe, & !< elastic deformation gradient Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient - real(pReal), dimension(3,3) :: E - real(pReal), dimension(6,6) :: C66 - real(pReal), dimension(3,3,3,3) :: C + real(pREAL), dimension(3,3) :: E + real(pREAL), dimension(6,6) :: C66 + real(pREAL), dimension(3,3,3,3) :: C integer :: & i, j @@ -179,12 +179,12 @@ module subroutine phase_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & C66 = phase_damage_C66(phase_homogenizedC66(ph,en),ph,en) C = math_Voigt66to3333_stiffness(C66) - E = 0.5_pReal*(matmul(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration + E = 0.5_pREAL*(matmul(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration S = math_Voigt6to33_stress(matmul(C66,math_33toVoigt6_strain(matmul(matmul(transpose(Fi),E),Fi))))!< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration do i =1,3; do j=1,3 dS_dFe(i,j,1:3,1:3) = matmul(Fe,matmul(matmul(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dS_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko - dS_dFi(i,j,1:3,1:3) = 2.0_pReal*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn + dS_dFi(i,j,1:3,1:3) = 2.0_pREAL*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn end do; end do end subroutine phase_hooke_SandItsTangents @@ -195,7 +195,7 @@ end subroutine phase_hooke_SandItsTangents !-------------------------------------------------------------------------------------------------- module function phase_homogenizedC66(ph,en) result(C) - real(pReal), dimension(6,6) :: C + real(pREAL), dimension(6,6) :: C integer, intent(in) :: ph, en diff --git a/src/phase_mechanical_plastic.f90 b/src/phase_mechanical_plastic.f90 index c4736ea29..0c1959660 100644 --- a/src/phase_mechanical_plastic.f90 +++ b/src/phase_mechanical_plastic.f90 @@ -38,11 +38,11 @@ submodule(phase:mechanical) plastic end function plastic_nonlocal_init module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -50,11 +50,11 @@ submodule(phase:mechanical) plastic end subroutine isotropic_LpAndItsTangent pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -62,11 +62,11 @@ submodule(phase:mechanical) plastic end subroutine phenopowerlaw_LpAndItsTangent pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -74,11 +74,11 @@ submodule(phase:mechanical) plastic end subroutine kinehardening_LpAndItsTangent module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -86,11 +86,11 @@ submodule(phase:mechanical) plastic end subroutine dislotwin_LpAndItsTangent pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -98,11 +98,11 @@ submodule(phase:mechanical) plastic end subroutine dislotungsten_LpAndItsTangent module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & @@ -111,59 +111,59 @@ submodule(phase:mechanical) plastic module function isotropic_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function isotropic_dotState module function phenopowerlaw_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function phenopowerlaw_dotState module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function plastic_kinehardening_dotState module function dislotwin_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function dislotwin_dotState module function dislotungsten_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState end function dislotungsten_dotState module subroutine nonlocal_dotState(Mp,timestep,ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< MandelStress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & timestep !< substepped crystallite time increment integer, intent(in) :: & ph, & @@ -189,7 +189,7 @@ submodule(phase:mechanical) plastic end subroutine nonlocal_dependentState module subroutine plastic_kinehardening_deltaState(Mp,ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & @@ -197,7 +197,7 @@ submodule(phase:mechanical) plastic end subroutine plastic_kinehardening_deltaState module subroutine plastic_nonlocal_deltaState(Mp,ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp integer, intent(in) :: & ph, & @@ -234,27 +234,27 @@ module subroutine plastic_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & S, Fi, ph,en) integer, intent(in) :: & ph,en - real(pReal), intent(in), dimension(3,3) :: & + real(pREAL), intent(in), dimension(3,3) :: & S, & !< 2nd Piola-Kirchhoff stress Fi !< intermediate deformation gradient - real(pReal), intent(out), dimension(3,3) :: & + real(pREAL), intent(out), dimension(3,3) :: & Lp !< plastic velocity gradient - real(pReal), intent(out), dimension(3,3,3,3) :: & + real(pREAL), intent(out), dimension(3,3,3,3) :: & dLp_dS, & dLp_dFi !< derivative en Lp with respect to Fi - real(pReal), dimension(3,3,3,3) :: & + real(pREAL), dimension(3,3,3,3) :: & dLp_dMp !< derivative of Lp with respect to Mandel stress - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & Mp !< Mandel stress work conjugate with Lp integer :: & i, j if (phase_plasticity(ph) == PLASTIC_NONE_ID) then - Lp = 0.0_pReal - dLp_dFi = 0.0_pReal - dLp_dS = 0.0_pReal + Lp = 0.0_pREAL + dLp_dFi = 0.0_pREAL + dLp_dS = 0.0_pREAL else Mp = matmul(matmul(transpose(Fi),Fi),S) @@ -300,11 +300,11 @@ module function plastic_dotState(subdt,ph,en) result(dotState) integer, intent(in) :: & ph, & en - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & subdt !< timestep - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & Mp - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState @@ -376,7 +376,7 @@ module function plastic_deltaState(ph, en) result(broken) en logical :: broken - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & Mp integer :: & mySize diff --git a/src/phase_mechanical_plastic_dislotungsten.f90 b/src/phase_mechanical_plastic_dislotungsten.f90 index 45a2f029f..846551989 100644 --- a/src/phase_mechanical_plastic_dislotungsten.f90 +++ b/src/phase_mechanical_plastic_dislotungsten.f90 @@ -8,11 +8,11 @@ submodule(phase:plastic) dislotungsten type :: tParameters - real(pReal) :: & - D = 1.0_pReal, & !< grain size - D_0 = 1.0_pReal, & !< prefactor for self-diffusion coefficient - Q_cl = 1.0_pReal !< activation energy for dislocation climb - real(pReal), allocatable, dimension(:) :: & + real(pREAL) :: & + D = 1.0_pREAL, & !< grain size + D_0 = 1.0_pREAL, & !< prefactor for self-diffusion coefficient + Q_cl = 1.0_pREAL !< activation energy for dislocation climb + real(pREAL), allocatable, dimension(:) :: & b_sl, & !< magnitude of Burgers vector [m] d_caron, & !< distance of spontaneous annhihilation i_sl, & !< Adj. parameter for distance between 2 forest dislocations @@ -26,10 +26,10 @@ submodule(phase:plastic) dislotungsten h, & !< height of the kink pair w, & !< width of the kink pair omega !< attempt frequency for kink pair nucleation - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & h_sl_sl, & !< slip resistance from slip activity forestProjection - real(pReal), allocatable, dimension(:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:) :: & P_sl, & P_nS_pos, & P_nS_neg @@ -53,14 +53,14 @@ submodule(phase:plastic) dislotungsten end type tIndexDotState type :: tDislotungstenState - real(pReal), dimension(:,:), pointer :: & + real(pREAL), dimension(:,:), pointer :: & rho_mob, & rho_dip, & gamma_sl end type tDislotungstenState type :: tDislotungstenDependentState - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & Lambda_sl, & tau_pass end type tDislotungstenDependentState @@ -89,7 +89,7 @@ module function plastic_dislotungsten_init() result(myPlasticity) startIndex, endIndex integer, dimension(:), allocatable :: & N_sl - real(pReal),dimension(:), allocatable :: & + real(pREAL),dimension(:), allocatable :: & rho_mob_0, & !< initial dislocation density rho_dip_0, & !< initial dipole density a !< non-Schmid coefficients @@ -203,16 +203,16 @@ module function plastic_dislotungsten_init() result(myPlasticity) prm%d_caron = pl%get_asReal('D_a') * prm%b_sl ! sanity checks - if ( prm%D_0 < 0.0_pReal) extmsg = trim(extmsg)//' D_0' - if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' - if (any(rho_mob_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_mob_0' - if (any(rho_dip_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_dip_0' - if (any(prm%b_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl' - if (any(prm%Q_s <= 0.0_pReal)) extmsg = trim(extmsg)//' Q_s' - if (any(prm%tau_Peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_Peierls' - if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//' B' - if (any(prm%d_caron < 0.0_pReal)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' - if (any(prm%f_at <= 0.0_pReal)) extmsg = trim(extmsg)//' f_at or b_sl' + if ( prm%D_0 < 0.0_pREAL) extmsg = trim(extmsg)//' D_0' + if ( prm%Q_cl <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl' + if (any(rho_mob_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_mob_0' + if (any(rho_dip_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_dip_0' + if (any(prm%b_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' b_sl' + if (any(prm%Q_s <= 0.0_pREAL)) extmsg = trim(extmsg)//' Q_s' + if (any(prm%tau_Peierls < 0.0_pREAL)) extmsg = trim(extmsg)//' tau_Peierls' + if (any(prm%B < 0.0_pREAL)) extmsg = trim(extmsg)//' B' + if (any(prm%d_caron < 0.0_pREAL)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' + if (any(prm%f_at <= 0.0_pREAL)) extmsg = trim(extmsg)//' f_at or b_sl' else slipActive rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray @@ -239,25 +239,25 @@ module function plastic_dislotungsten_init() result(myPlasticity) idx_dot%rho_mob = [startIndex,endIndex] stt%rho_mob => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob = spread(rho_mob_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_rho' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%rho_dip = [startIndex,endIndex] stt%rho_dip => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip = spread(rho_dip_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma' - allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pReal) - allocate(dst%tau_pass(prm%sum_N_sl,Nmembers), source=0.0_pReal) + allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pREAL) + allocate(dst%tau_pass(prm%sum_N_sl,Nmembers), source=0.0_pREAL) end associate @@ -275,11 +275,11 @@ end function plastic_dislotungsten_init !-------------------------------------------------------------------------------------------------- pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, & Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & @@ -287,16 +287,16 @@ pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, & integer :: & i,k,l,m,n - real(pReal) :: & + real(pREAL) :: & T !< temperature - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos,dot_gamma_neg, & ddot_gamma_dtau_pos,ddot_gamma_dtau_neg T = thermal_T(ph,en) - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL associate(prm => param(ph)) @@ -319,15 +319,15 @@ end subroutine dislotungsten_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module function dislotungsten_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos, dot_gamma_neg,& tau_pos,& tau_neg, & @@ -335,7 +335,7 @@ module function dislotungsten_dotState(Mp,ph,en) result(dotState) dot_rho_dip_formation, & dot_rho_dip_climb, & d_hat - real(pReal) :: & + real(pREAL) :: & mu, T @@ -353,26 +353,26 @@ module function dislotungsten_dotState(Mp,ph,en) result(dotState) dot_gamma_sl = abs(dot_gamma_pos+dot_gamma_neg) - where(dEq0((tau_pos+tau_neg)*0.5_pReal)) - dot_rho_dip_formation = 0.0_pReal - dot_rho_dip_climb = 0.0_pReal + where(dEq0((tau_pos+tau_neg)*0.5_pREAL)) + dot_rho_dip_formation = 0.0_pREAL + dot_rho_dip_climb = 0.0_pREAL else where - d_hat = math_clip(3.0_pReal*mu*prm%b_sl/(16.0_pReal*PI*abs(tau_pos+tau_neg)*0.5_pReal), & + d_hat = math_clip(3.0_pREAL*mu*prm%b_sl/(16.0_pREAL*PI*abs(tau_pos+tau_neg)*0.5_pREAL), & prm%d_caron, & ! lower limit dst%Lambda_sl(:,en)) ! upper limit - dot_rho_dip_formation = merge(2.0_pReal*(d_hat-prm%d_caron)*stt%rho_mob(:,en)*dot_gamma_sl/prm%b_sl, & - 0.0_pReal, & + dot_rho_dip_formation = merge(2.0_pREAL*(d_hat-prm%d_caron)*stt%rho_mob(:,en)*dot_gamma_sl/prm%b_sl, & + 0.0_pREAL, & prm%dipoleformation) - v_cl = (3.0_pReal*mu*prm%D_0*exp(-prm%Q_cl/(K_B*T))*prm%f_at/(TAU*K_B*T)) & - * (1.0_pReal/(d_hat+prm%d_caron)) - dot_rho_dip_climb = (4.0_pReal*v_cl*stt%rho_dip(:,en))/(d_hat-prm%d_caron) ! ToDo: Discuss with Franz: Stress dependency? + v_cl = (3.0_pREAL*mu*prm%D_0*exp(-prm%Q_cl/(K_B*T))*prm%f_at/(TAU*K_B*T)) & + * (1.0_pREAL/(d_hat+prm%d_caron)) + dot_rho_dip_climb = (4.0_pREAL*v_cl*stt%rho_dip(:,en))/(d_hat-prm%d_caron) ! ToDo: Discuss with Franz: Stress dependency? end where dot_rho_mob = dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & ! multiplication - dot_rho_dip_formation & - - (2.0_pReal*prm%d_caron)/prm%b_sl*stt%rho_mob(:,en)*dot_gamma_sl ! Spontaneous annihilation of 2 edges + - (2.0_pREAL*prm%d_caron)/prm%b_sl*stt%rho_mob(:,en)*dot_gamma_sl ! Spontaneous annihilation of 2 edges dot_rho_dip = dot_rho_dip_formation & - - (2.0_pReal*prm%d_caron)/prm%b_sl*stt%rho_dip(:,en)*dot_gamma_sl & ! Spontaneous annihilation of an edge with a dipole + - (2.0_pREAL*prm%d_caron)/prm%b_sl*stt%rho_dip(:,en)*dot_gamma_sl & ! Spontaneous annihilation of an edge with a dipole - dot_rho_dip_climb end associate @@ -389,7 +389,7 @@ module subroutine dislotungsten_dependentState(ph,en) ph, & en - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & Lambda_sl_inv @@ -398,9 +398,9 @@ module subroutine dislotungsten_dependentState(ph,en) dst%tau_pass(:,en) = elastic_mu(ph,en,prm%isotropic_bound)*prm%b_sl & * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en))) - Lambda_sl_inv = 1.0_pReal/prm%D & + Lambda_sl_inv = 1.0_pREAL/prm%D & + sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl - dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pReal) + dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pREAL) end associate @@ -458,24 +458,24 @@ end subroutine plastic_dislotungsten_result pure subroutine kinetics(Mp,T,ph,en, & dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & T !< temperature integer, intent(in) :: & ph, & en - real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos, & dot_gamma_neg - real(pReal), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & + real(pREAL), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & ddot_gamma_dtau_pos, & ddot_gamma_dtau_neg, & tau_pos_out, & tau_neg_out - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & StressRatio, & StressRatio_p,StressRatio_pminus1, & dvel, & @@ -495,7 +495,7 @@ pure subroutine kinetics(Mp,T,ph,en, & if (present(tau_neg_out)) tau_neg_out = tau_neg associate(BoltzmannRatio => prm%Q_s/(K_B*T), & - b_rho_half => stt%rho_mob(:,en) * prm%b_sl * 0.5_pReal, & + b_rho_half => stt%rho_mob(:,en) * prm%b_sl * 0.5_pREAL, & effectiveLength => dst%Lambda_sl(:,en) - prm%w) tau_eff = abs(tau_pos)-dst%tau_pass(:,en) @@ -503,28 +503,28 @@ pure subroutine kinetics(Mp,T,ph,en, & significantPositiveTau: where(tau_eff > tol_math_check) StressRatio = tau_eff/prm%tau_Peierls StressRatio_p = StressRatio** prm%p - StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + StressRatio_pminus1 = StressRatio**(prm%p-1.0_pREAL) - t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pReal-StressRatio_p) ** prm%q) & + t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pREAL-StressRatio_p) ** prm%q) & / (prm%omega*effectiveLength) - t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_eff) ! corrected eq. (14) + t_k = effectiveLength * prm%B /(2.0_pREAL*prm%b_sl*tau_eff) ! corrected eq. (14) dot_gamma_pos = b_rho_half * sign(prm%h/(t_n + t_k),tau_pos) else where significantPositiveTau - dot_gamma_pos = 0.0_pReal + dot_gamma_pos = 0.0_pREAL end where significantPositiveTau if (present(ddot_gamma_dtau_pos)) then significantPositiveTau2: where(abs(tau_pos)-dst%tau_pass(:,en) > tol_math_check) - dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) & + dtn = -1.0_pREAL * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pREAL-StressRatio_p)**(prm%q - 1.0_pREAL) & * StressRatio_pminus1 / prm%tau_Peierls - dtk = -1.0_pReal * t_k / tau_pos + dtk = -1.0_pREAL * t_k / tau_pos - dvel = -1.0_pReal * prm%h * (dtk + dtn) / (t_n + t_k)**2 + dvel = -1.0_pREAL * prm%h * (dtk + dtn) / (t_n + t_k)**2 ddot_gamma_dtau_pos = b_rho_half * dvel else where significantPositiveTau2 - ddot_gamma_dtau_pos = 0.0_pReal + ddot_gamma_dtau_pos = 0.0_pREAL end where significantPositiveTau2 end if @@ -533,28 +533,28 @@ pure subroutine kinetics(Mp,T,ph,en, & significantNegativeTau: where(tau_eff > tol_math_check) StressRatio = tau_eff/prm%tau_Peierls StressRatio_p = StressRatio** prm%p - StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) + StressRatio_pminus1 = StressRatio**(prm%p-1.0_pREAL) - t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pReal-StressRatio_p) ** prm%q) & + t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pREAL-StressRatio_p) ** prm%q) & / (prm%omega*effectiveLength) - t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_eff) ! corrected eq. (14) + t_k = effectiveLength * prm%B /(2.0_pREAL*prm%b_sl*tau_eff) ! corrected eq. (14) dot_gamma_neg = b_rho_half * sign(prm%h/(t_n + t_k),tau_neg) else where significantNegativeTau - dot_gamma_neg = 0.0_pReal + dot_gamma_neg = 0.0_pREAL end where significantNegativeTau if (present(ddot_gamma_dtau_neg)) then significantNegativeTau2: where(abs(tau_neg)-dst%tau_pass(:,en) > tol_math_check) - dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) & + dtn = -1.0_pREAL * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pREAL-StressRatio_p)**(prm%q - 1.0_pREAL) & * StressRatio_pminus1 / prm%tau_Peierls - dtk = -1.0_pReal * t_k / tau_neg + dtk = -1.0_pREAL * t_k / tau_neg - dvel = -1.0_pReal * prm%h * (dtk + dtn) / (t_n + t_k)**2 + dvel = -1.0_pREAL * prm%h * (dtk + dtn) / (t_n + t_k)**2 ddot_gamma_dtau_neg = b_rho_half * dvel else where significantNegativeTau2 - ddot_gamma_dtau_neg = 0.0_pReal + ddot_gamma_dtau_neg = 0.0_pREAL end where significantNegativeTau2 end if diff --git a/src/phase_mechanical_plastic_dislotwin.f90 b/src/phase_mechanical_plastic_dislotwin.f90 index ea8570ba0..05becb028 100644 --- a/src/phase_mechanical_plastic_dislotwin.f90 +++ b/src/phase_mechanical_plastic_dislotwin.f90 @@ -9,31 +9,31 @@ !-------------------------------------------------------------------------------------------------- submodule(phase:plastic) dislotwin - real(pReal), parameter :: gamma_char_tr = sqrt(0.125_pReal) !< Characteristic shear for transformation + real(pREAL), parameter :: gamma_char_tr = sqrt(0.125_pREAL) !< Characteristic shear for transformation type :: tParameters - real(pReal) :: & - Q_cl = 1.0_pReal, & !< activation energy for dislocation climb - omega = 1.0_pReal, & !< frequency factor for dislocation climb - D = 1.0_pReal, & !< grain size - p_sb = 1.0_pReal, & !< p-exponent in shear band velocity - q_sb = 1.0_pReal, & !< q-exponent in shear band velocity - i_tw = 1.0_pReal, & !< adjustment parameter to calculate MFP for twinning - i_tr = 1.0_pReal, & !< adjustment parameter to calculate MFP for transformation - L_tw = 1.0_pReal, & !< length of twin nuclei - L_tr = 1.0_pReal, & !< length of trans nuclei - x_c = 1.0_pReal, & !< critical distance for formation of twin/trans nucleus - V_cs = 1.0_pReal, & !< cross slip volume - tau_sb = 1.0_pReal, & !< value for shearband resistance - gamma_0_sb = 1.0_pReal, & !< value for shearband velocity_0 - E_sb = 1.0_pReal, & !< activation energy for shear bands - h = 1.0_pReal, & !< stack height of hex nucleus - cOverA_hP = 1.0_pReal, & - V_mol = 1.0_pReal, & - rho = 1.0_pReal + real(pREAL) :: & + Q_cl = 1.0_pREAL, & !< activation energy for dislocation climb + omega = 1.0_pREAL, & !< frequency factor for dislocation climb + D = 1.0_pREAL, & !< grain size + p_sb = 1.0_pREAL, & !< p-exponent in shear band velocity + q_sb = 1.0_pREAL, & !< q-exponent in shear band velocity + i_tw = 1.0_pREAL, & !< adjustment parameter to calculate MFP for twinning + i_tr = 1.0_pREAL, & !< adjustment parameter to calculate MFP for transformation + L_tw = 1.0_pREAL, & !< length of twin nuclei + L_tr = 1.0_pREAL, & !< length of trans nuclei + x_c = 1.0_pREAL, & !< critical distance for formation of twin/trans nucleus + V_cs = 1.0_pREAL, & !< cross slip volume + tau_sb = 1.0_pREAL, & !< value for shearband resistance + gamma_0_sb = 1.0_pREAL, & !< value for shearband velocity_0 + E_sb = 1.0_pREAL, & !< activation energy for shear bands + h = 1.0_pREAL, & !< stack height of hex nucleus + cOverA_hP = 1.0_pREAL, & + V_mol = 1.0_pREAL, & + rho = 1.0_pREAL type(tPolynomial) :: & Gamma_sf, & !< stacking fault energy Delta_G !< free energy difference between austensite and martensite - real(pReal), allocatable, dimension(:) :: & + real(pREAL), allocatable, dimension(:) :: & b_sl, & !< absolute length of Burgers vector [m] for each slip system b_tw, & !< absolute length of Burgers vector [m] for each twin system b_tr, & !< absolute length of Burgers vector [m] for each transformation system @@ -51,7 +51,7 @@ submodule(phase:plastic) dislotwin gamma_char_tw, & !< characteristic shear for twins B, & !< drag coefficient d_caron !< distance of spontaneous annhihilation - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & h_sl_sl, & !< components of slip-slip interaction matrix h_sl_tw, & !< components of slip-twin interaction matrix h_sl_tr, & !< components of slip-trans interaction matrix @@ -59,7 +59,7 @@ submodule(phase:plastic) dislotwin h_tr_tr, & !< components of trans-trans interaction matrix n0_sl, & !< slip system normal forestProjection - real(pReal), allocatable, dimension(:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:) :: & P_sl, & P_tw, & P_tr @@ -96,7 +96,7 @@ submodule(phase:plastic) dislotwin end type tIndexDotState type :: tDislotwinState - real(pReal), dimension(:,:), pointer :: & + real(pREAL), dimension(:,:), pointer :: & rho_mob, & rho_dip, & gamma_sl, & @@ -105,7 +105,7 @@ submodule(phase:plastic) dislotwin end type tDislotwinState type :: tDislotwinDependentState - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & Lambda_sl, & !< mean free path between 2 obstacles seen by a moving dislocation Lambda_tw, & !< mean free path between 2 obstacles seen by a growing twin Lambda_tr, & !< mean free path between 2 obstacles seen by a growing martensite @@ -136,8 +136,8 @@ module function plastic_dislotwin_init() result(myPlasticity) startIndex, endIndex integer, dimension(:), allocatable :: & N_sl - real(pReal) :: a_cF - real(pReal), allocatable, dimension(:) :: & + real(pREAL) :: a_cF + real(pREAL), allocatable, dimension(:) :: & rho_mob_0, & !< initial unipolar dislocation density per slip system rho_dip_0 !< initial dipole dislocation density per slip system character(len=:), allocatable :: & @@ -220,7 +220,7 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl)) prm%tau_0 = pl%get_as1dReal('tau_0', requiredSize=size(N_sl)) prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl), & - defaultVal=[(0.0_pReal, i=1,size(N_sl))]) + defaultVal=[(0.0_pREAL, i=1,size(N_sl))]) prm%Q_cl = pl%get_asReal('Q_cl') @@ -229,8 +229,8 @@ module function plastic_dislotwin_init() result(myPlasticity) ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex) ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981 - prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pReal) & - * merge(12.0_pReal,8.0_pReal,any(phase_lattice(ph) == ['cF','hP'])) + prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pREAL) & + * merge(12.0_pREAL,8.0_pREAL,any(phase_lattice(ph) == ['cF','hP'])) ! expand: family => system rho_mob_0 = math_expand(rho_mob_0, N_sl) @@ -246,17 +246,17 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%d_caron = pl%get_asReal('D_a') * prm%b_sl ! sanity checks - if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' - if (any(rho_mob_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_mob_0' - if (any(rho_dip_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_dip_0' - if (any(prm%v_0 < 0.0_pReal)) extmsg = trim(extmsg)//' v_0' - if (any(prm%b_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl' - if (any(prm%Q_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' Q_sl' - if (any(prm%i_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' i_sl' - if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//' B' - if (any(prm%d_caron < 0.0_pReal)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' - if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//' p_sl' - if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//' q_sl' + if ( prm%Q_cl <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl' + if (any(rho_mob_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_mob_0' + if (any(rho_dip_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_dip_0' + if (any(prm%v_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' v_0' + if (any(prm%b_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' b_sl' + if (any(prm%Q_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' Q_sl' + if (any(prm%i_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' i_sl' + if (any(prm%B < 0.0_pREAL)) extmsg = trim(extmsg)//' B' + if (any(prm%d_caron < 0.0_pREAL)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' + if (any(prm%p<=0.0_pREAL .or. prm%p>1.0_pREAL)) extmsg = trim(extmsg)//' p_sl' + if (any(prm%q< 1.0_pREAL .or. prm%q>2.0_pREAL)) extmsg = trim(extmsg)//' q_sl' else slipActive rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray allocate(prm%b_sl,prm%Q_sl,prm%v_0,prm%i_sl,prm%p,prm%q,prm%B,source=emptyRealArray) @@ -289,11 +289,11 @@ module function plastic_dislotwin_init() result(myPlasticity) ! sanity checks if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TWIP for non-fcc' - if ( prm%L_tw < 0.0_pReal) extmsg = trim(extmsg)//' L_tw' - if ( prm%i_tw < 0.0_pReal) extmsg = trim(extmsg)//' i_tw' - if (any(prm%b_tw < 0.0_pReal)) extmsg = trim(extmsg)//' b_tw' - if (any(prm%t_tw < 0.0_pReal)) extmsg = trim(extmsg)//' t_tw' - if (any(prm%r < 0.0_pReal)) extmsg = trim(extmsg)//' p_tw' + if ( prm%L_tw < 0.0_pREAL) extmsg = trim(extmsg)//' L_tw' + if ( prm%i_tw < 0.0_pREAL) extmsg = trim(extmsg)//' i_tw' + if (any(prm%b_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' b_tw' + if (any(prm%t_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tw' + if (any(prm%r < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tw' else twinActive allocate(prm%gamma_char_tw,prm%b_tw,prm%t_tw,prm%r,source=emptyRealArray) allocate(prm%h_tw_tw(0,0)) @@ -310,10 +310,10 @@ module function plastic_dislotwin_init() result(myPlasticity) prm%i_tr = pl%get_asReal('i_tr') prm%Delta_G = polynomial(pl,'Delta_G','T') prm%L_tr = pl%get_asReal('L_tr') - a_cF = prm%b_tr(1)*sqrt(6.0_pReal) ! b_tr is Shockley partial - prm%h = 5.0_pReal * a_cF/sqrt(3.0_pReal) + a_cF = prm%b_tr(1)*sqrt(6.0_pREAL) ! b_tr is Shockley partial + prm%h = 5.0_pREAL * a_cF/sqrt(3.0_pREAL) prm%cOverA_hP = pl%get_asReal('c/a_hP') - prm%rho = 4.0_pReal/(sqrt(3.0_pReal)*a_cF**2)/N_A + prm%rho = 4.0_pREAL/(sqrt(3.0_pREAL)*a_cF**2)/N_A prm%V_mol = pl%get_asReal('V_mol') prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dReal('h_tr-tr'),& phase_lattice(ph)) @@ -327,11 +327,11 @@ module function plastic_dislotwin_init() result(myPlasticity) ! sanity checks if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TRIP for non-fcc' - if ( prm%L_tr < 0.0_pReal) extmsg = trim(extmsg)//' L_tr' - if ( prm%V_mol < 0.0_pReal) extmsg = trim(extmsg)//' V_mol' - if ( prm%i_tr < 0.0_pReal) extmsg = trim(extmsg)//' i_tr' - if (any(prm%t_tr < 0.0_pReal)) extmsg = trim(extmsg)//' t_tr' - if (any(prm%s < 0.0_pReal)) extmsg = trim(extmsg)//' p_tr' + if ( prm%L_tr < 0.0_pREAL) extmsg = trim(extmsg)//' L_tr' + if ( prm%V_mol < 0.0_pREAL) extmsg = trim(extmsg)//' V_mol' + if ( prm%i_tr < 0.0_pREAL) extmsg = trim(extmsg)//' i_tr' + if (any(prm%t_tr < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tr' + if (any(prm%s < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tr' else transActive allocate(prm%s,prm%b_tr,prm%t_tr,source=emptyRealArray) allocate(prm%h_tr_tr(0,0)) @@ -339,18 +339,18 @@ module function plastic_dislotwin_init() result(myPlasticity) !-------------------------------------------------------------------------------------------------- ! shearband related parameters - prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pReal) - if (prm%gamma_0_sb > 0.0_pReal) then + prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pREAL) + if (prm%gamma_0_sb > 0.0_pREAL) then prm%tau_sb = pl%get_asReal('tau_sb') prm%E_sb = pl%get_asReal('Q_sb') prm%p_sb = pl%get_asReal('p_sb') prm%q_sb = pl%get_asReal('q_sb') ! sanity checks - if (prm%tau_sb < 0.0_pReal) extmsg = trim(extmsg)//' tau_sb' - if (prm%E_sb < 0.0_pReal) extmsg = trim(extmsg)//' Q_sb' - if (prm%p_sb <= 0.0_pReal) extmsg = trim(extmsg)//' p_sb' - if (prm%q_sb <= 0.0_pReal) extmsg = trim(extmsg)//' q_sb' + if (prm%tau_sb < 0.0_pREAL) extmsg = trim(extmsg)//' tau_sb' + if (prm%E_sb < 0.0_pREAL) extmsg = trim(extmsg)//' Q_sb' + if (prm%p_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' p_sb' + if (prm%q_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' q_sb' end if !-------------------------------------------------------------------------------------------------- @@ -361,8 +361,8 @@ module function plastic_dislotwin_init() result(myPlasticity) if (prm%sum_N_tw + prm%sum_N_tr > 0) then prm%x_c = pl%get_asReal('x_c') prm%V_cs = pl%get_asReal('V_cs') - if (prm%x_c < 0.0_pReal) extmsg = trim(extmsg)//' x_c' - if (prm%V_cs < 0.0_pReal) extmsg = trim(extmsg)//' V_cs' + if (prm%x_c < 0.0_pREAL) extmsg = trim(extmsg)//' x_c' + if (prm%V_cs < 0.0_pREAL) extmsg = trim(extmsg)//' V_cs' end if if (prm%sum_N_tw + prm%sum_N_tr > 0 .or. prm%extendedDislocations) & @@ -402,41 +402,41 @@ module function plastic_dislotwin_init() result(myPlasticity) idx_dot%rho_mob = [startIndex,endIndex] stt%rho_mob=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob= spread(rho_mob_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_rho' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%rho_dip = [startIndex,endIndex] stt%rho_dip=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip= spread(rho_dip_0,2,Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw idx_dot%f_tw = [startIndex,endIndex] stt%f_tw=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tw',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tw' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tw',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_f_tw' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tr idx_dot%f_tr = [startIndex,endIndex] stt%f_tr=>plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tr',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tr' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tr',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_f_tr' - allocate(dst%tau_pass (prm%sum_N_sl,Nmembers),source=0.0_pReal) - allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers),source=0.0_pReal) - allocate(dst%Lambda_tw(prm%sum_N_tw,Nmembers),source=0.0_pReal) - allocate(dst%Lambda_tr(prm%sum_N_tr,Nmembers),source=0.0_pReal) + allocate(dst%tau_pass (prm%sum_N_sl,Nmembers),source=0.0_pREAL) + allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers),source=0.0_pREAL) + allocate(dst%Lambda_tw(prm%sum_N_tw,Nmembers),source=0.0_pREAL) + allocate(dst%Lambda_tr(prm%sum_N_tr,Nmembers),source=0.0_pREAL) end associate @@ -456,21 +456,21 @@ module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC) integer, intent(in) :: & ph, en - real(pReal), dimension(6,6) :: & + real(pREAL), dimension(6,6) :: & homogenizedC, & C - real(pReal), dimension(:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:), allocatable :: & C66_tw, & C66_tr integer :: i - real(pReal) :: f_matrix + real(pREAL) :: f_matrix C = elastic_C66(ph,en) associate(prm => param(ph), stt => state(ph)) - f_matrix = 1.0_pReal & + f_matrix = 1.0_pREAL & - sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tr(1:prm%sum_N_tr,en)) @@ -502,28 +502,28 @@ end function plastic_dislotwin_homogenizedC !-------------------------------------------------------------------------------------------------- module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: Lp - real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp - real(pReal), dimension(3,3), intent(in) :: Mp + real(pREAL), dimension(3,3), intent(out) :: Lp + real(pREAL), dimension(3,3,3,3), intent(out) :: dLp_dMp + real(pREAL), dimension(3,3), intent(in) :: Mp integer, intent(in) :: ph,en integer :: i,k,l,m,n - real(pReal) :: & + real(pREAL) :: & f_matrix,StressRatio_p,& E_kB_T, & ddot_gamma_dtau, & tau, & T - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_sl,ddot_gamma_dtau_sl - real(pReal), dimension(param(ph)%sum_N_tw) :: & + real(pREAL), dimension(param(ph)%sum_N_tw) :: & dot_gamma_tw,ddot_gamma_dtau_tw - real(pReal), dimension(param(ph)%sum_N_tr) :: & + real(pREAL), dimension(param(ph)%sum_N_tr) :: & dot_gamma_tr,ddot_gamma_dtau_tr - real(pReal):: dot_gamma_sb - real(pReal), dimension(3,3) :: eigVectors, P_sb - real(pReal), dimension(3) :: eigValues - real(pReal), dimension(3,6), parameter :: & + real(pREAL):: dot_gamma_sb + real(pREAL), dimension(3,3) :: eigVectors, P_sb + real(pREAL), dimension(3) :: eigValues + real(pREAL), dimension(3,6), parameter :: & sb_sComposition = & reshape(real([& 1, 0, 1, & @@ -532,7 +532,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) 1,-1, 0, & 0, 1, 1, & 0, 1,-1 & - ],pReal),[ 3,6]), & + ],pREAL),[ 3,6]), & sb_mComposition = & reshape(real([& 1, 0,-1, & @@ -541,16 +541,16 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) 1, 1, 0, & 0, 1,-1, & 0, 1, 1 & - ],pReal),[ 3,6]) + ],pREAL),[ 3,6]) T = thermal_T(ph,en) - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL associate(prm => param(ph), stt => state(ph)) - f_matrix = 1.0_pReal & + f_matrix = 1.0_pREAL & - sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tr(1:prm%sum_N_tr,en)) @@ -587,7 +587,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) call math_eigh33(eigValues,eigVectors,Mp) ! is Mp symmetric by design? do i = 1,6 - P_sb = 0.5_pReal * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),& + P_sb = 0.5_pREAL * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),& matmul(eigVectors,sb_mComposition(1:3,i))) tau = math_tensordot(Mp,P_sb) @@ -595,8 +595,8 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) StressRatio_p = (abs(tau)/prm%tau_sb)**prm%p_sb dot_gamma_sb = sign(prm%gamma_0_sb*exp(-E_kB_T*(1-StressRatio_p)**prm%q_sb), tau) ddot_gamma_dtau = abs(dot_gamma_sb)*E_kB_T*prm%p_sb*prm%q_sb/prm%tau_sb & - * (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pReal) & - * (1.0_pReal-StressRatio_p)**(prm%q_sb-1.0_pReal) + * (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pREAL) & + * (1.0_pREAL-StressRatio_p)**(prm%q_sb-1.0_pREAL) Lp = Lp + dot_gamma_sb * P_sb forall (k=1:3,l=1:3,m=1:3,n=1:3) & @@ -617,31 +617,31 @@ end subroutine dislotwin_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module function dislotwin_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in):: & + real(pREAL), dimension(3,3), intent(in):: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState integer :: i - real(pReal) :: & + real(pREAL) :: & f_matrix, & d_hat, & v_cl, & !< climb velocity tau, & sigma_cl, & !< climb stress b_d !< ratio of Burgers vector to stacking fault width - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_rho_dip_formation, & dot_rho_dip_climb, & dot_gamma_sl - real(pReal), dimension(param(ph)%sum_N_tw) :: & + real(pREAL), dimension(param(ph)%sum_N_tw) :: & dot_gamma_tw - real(pReal), dimension(param(ph)%sum_N_tr) :: & + real(pREAL), dimension(param(ph)%sum_N_tr) :: & dot_gamma_tr - real(pReal) :: & + real(pREAL) :: & mu, nu, & T @@ -657,7 +657,7 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState) nu = elastic_nu(ph,en,prm%isotropic_bound) T = thermal_T(ph,en) - f_matrix = 1.0_pReal & + f_matrix = 1.0_pREAL & - sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tr(1:prm%sum_N_tr,en)) @@ -668,30 +668,30 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState) tau = math_tensordot(Mp,prm%P_sl(1:3,1:3,i)) significantSlipStress: if (dEq0(tau) .or. prm%omitDipoles) then - dot_rho_dip_formation(i) = 0.0_pReal - dot_rho_dip_climb(i) = 0.0_pReal + dot_rho_dip_formation(i) = 0.0_pREAL + dot_rho_dip_climb(i) = 0.0_pREAL else significantSlipStress - d_hat = 3.0_pReal*mu*prm%b_sl(i)/(16.0_pReal*PI*abs(tau)) + d_hat = 3.0_pREAL*mu*prm%b_sl(i)/(16.0_pREAL*PI*abs(tau)) d_hat = math_clip(d_hat, right = dst%Lambda_sl(i,en)) d_hat = math_clip(d_hat, left = prm%d_caron(i)) - dot_rho_dip_formation(i) = 2.0_pReal*(d_hat-prm%d_caron(i))/prm%b_sl(i) & + dot_rho_dip_formation(i) = 2.0_pREAL*(d_hat-prm%d_caron(i))/prm%b_sl(i) & * stt%rho_mob(i,en)*abs_dot_gamma_sl(i) if (dEq(d_hat,prm%d_caron(i))) then - dot_rho_dip_climb(i) = 0.0_pReal + dot_rho_dip_climb(i) = 0.0_pREAL else ! Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981 sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i))) if (prm%extendedDislocations) then - b_d = 24.0_pReal*PI*(1.0_pReal - nu)/(2.0_pReal + nu) * prm%Gamma_sf%at(T) / (mu*prm%b_sl(i)) + b_d = 24.0_pREAL*PI*(1.0_pREAL - nu)/(2.0_pREAL + nu) * prm%Gamma_sf%at(T) / (mu*prm%b_sl(i)) else - b_d = 1.0_pReal + b_d = 1.0_pREAL end if - v_cl = 2.0_pReal*prm%omega*b_d**2*exp(-prm%Q_cl/(K_B*T)) & - * (exp(abs(sigma_cl)*prm%b_sl(i)**3/(K_B*T)) - 1.0_pReal) + v_cl = 2.0_pREAL*prm%omega*b_d**2*exp(-prm%Q_cl/(K_B*T)) & + * (exp(abs(sigma_cl)*prm%b_sl(i)**3/(K_B*T)) - 1.0_pREAL) - dot_rho_dip_climb(i) = 4.0_pReal*v_cl*stt%rho_dip(i,en) & + dot_rho_dip_climb(i) = 4.0_pREAL*v_cl*stt%rho_dip(i,en) & / (d_hat-prm%d_caron(i)) end if end if significantSlipStress @@ -699,10 +699,10 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState) dot_rho_mob = abs_dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & - dot_rho_dip_formation & - - 2.0_pReal*prm%d_caron/prm%b_sl * stt%rho_mob(:,en)*abs_dot_gamma_sl + - 2.0_pREAL*prm%d_caron/prm%b_sl * stt%rho_mob(:,en)*abs_dot_gamma_sl dot_rho_dip = dot_rho_dip_formation & - - 2.0_pReal*prm%d_caron/prm%b_sl * stt%rho_dip(:,en)*abs_dot_gamma_sl & + - 2.0_pREAL*prm%d_caron/prm%b_sl * stt%rho_dip(:,en)*abs_dot_gamma_sl & - dot_rho_dip_climb if (prm%sum_N_tw > 0) call kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,dot_gamma_tw) @@ -725,17 +725,17 @@ module subroutine dislotwin_dependentState(ph,en) ph, & en - real(pReal) :: & + real(pREAL) :: & sumf_tw, sumf_tr - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & inv_lambda_sl - real(pReal), dimension(param(ph)%sum_N_tw) :: & + real(pREAL), dimension(param(ph)%sum_N_tw) :: & inv_lambda_tw_tw, & !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin f_over_t_tw - real(pReal), dimension(param(ph)%sum_N_tr) :: & + real(pREAL), dimension(param(ph)%sum_N_tr) :: & inv_lambda_tr_tr, & !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite f_over_t_tr - real(pReal) :: & + real(pREAL) :: & mu @@ -752,16 +752,16 @@ module subroutine dislotwin_dependentState(ph,en) inv_lambda_sl = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) & - inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pReal-sumf_tw) + inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pREAL-sumf_tw) if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) & - inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pReal-sumf_tr) - dst%Lambda_sl(:,en) = prm%D / (1.0_pReal+prm%D*inv_lambda_sl) + inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pREAL-sumf_tr) + dst%Lambda_sl(:,en) = prm%D / (1.0_pREAL+prm%D*inv_lambda_sl) - inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pReal-sumf_tw) - dst%Lambda_tw(:,en) = prm%i_tw*prm%D/(1.0_pReal+prm%D*inv_lambda_tw_tw) + inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pREAL-sumf_tw) + dst%Lambda_tw(:,en) = prm%i_tw*prm%D/(1.0_pREAL+prm%D*inv_lambda_tw_tw) - inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pReal-sumf_tr) - dst%Lambda_tr(:,en) = prm%i_tr*prm%D/(1.0_pReal+prm%D*inv_lambda_tr_tr) + inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pREAL-sumf_tr) + dst%Lambda_tr(:,en) = prm%i_tr*prm%D/(1.0_pREAL+prm%D*inv_lambda_tr_tr) !* threshold stress for dislocation motion dst%tau_pass(:,en) = mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en))) @@ -834,22 +834,22 @@ end subroutine plastic_dislotwin_result pure subroutine kinetics_sl(Mp,T,ph,en, & dot_gamma_sl,ddot_gamma_dtau_sl,tau_sl) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & T !< temperature integer, intent(in) :: & ph, & en - real(pReal), dimension(param(ph)%sum_N_sl), intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), intent(out) :: & dot_gamma_sl - real(pReal), dimension(param(ph)%sum_N_sl), optional, intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), optional, intent(out) :: & ddot_gamma_dtau_sl, & tau_sl - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & ddot_gamma_dtau - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau, & stressRatio, & StressRatio_p, & @@ -873,23 +873,23 @@ pure subroutine kinetics_sl(Mp,T,ph,en, & stressRatio = tau_eff/prm%tau_0 StressRatio_p = stressRatio** prm%p Q_kB_T = prm%Q_sl/(K_B*T) - v_wait_inverse = exp(Q_kB_T*(1.0_pReal-StressRatio_p)** prm%q) & + v_wait_inverse = exp(Q_kB_T*(1.0_pREAL-StressRatio_p)** prm%q) & / prm%v_0 v_run_inverse = prm%B/(tau_eff*prm%b_sl) dot_gamma_sl = sign(stt%rho_mob(:,en)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau) - dV_wait_inverse_dTau = -1.0_pReal * v_wait_inverse * prm%p * prm%q * Q_kB_T & - * (stressRatio**(prm%p-1.0_pReal)) & - * (1.0_pReal-StressRatio_p)**(prm%q-1.0_pReal) & + dV_wait_inverse_dTau = -1.0_pREAL * v_wait_inverse * prm%p * prm%q * Q_kB_T & + * (stressRatio**(prm%p-1.0_pREAL)) & + * (1.0_pREAL-StressRatio_p)**(prm%q-1.0_pREAL) & / prm%tau_0 - dV_run_inverse_dTau = -1.0_pReal * v_run_inverse/tau_eff - dV_dTau = -1.0_pReal * (dV_wait_inverse_dTau+dV_run_inverse_dTau) & + dV_run_inverse_dTau = -1.0_pREAL * v_run_inverse/tau_eff + dV_dTau = -1.0_pREAL * (dV_wait_inverse_dTau+dV_run_inverse_dTau) & / (v_wait_inverse+v_run_inverse)**2 ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,en)*prm%b_sl else where significantStress - dot_gamma_sl = 0.0_pReal - ddot_gamma_dtau = 0.0_pReal + dot_gamma_sl = 0.0_pREAL + ddot_gamma_dtau = 0.0_pREAL end where significantStress end associate @@ -910,21 +910,21 @@ end subroutine kinetics_sl pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,& dot_gamma_tw,ddot_gamma_dtau_tw) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & T !< temperature integer, intent(in) :: & ph, & en - real(pReal), dimension(param(ph)%sum_N_sl), intent(in) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), intent(in) :: & abs_dot_gamma_sl - real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: & dot_gamma_tw - real(pReal), dimension(param(ph)%sum_N_tw), optional, intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_tw), optional, intent(out) :: & ddot_gamma_dtau_tw - real(pReal) :: & + real(pREAL) :: & tau, tau_r, tau_hat, & dot_N_0, & x0, V, & @@ -943,10 +943,10 @@ pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,& nu = elastic_nu(ph,en,prm%isotropic_bound) Gamma_sf = prm%Gamma_sf%at(T) - tau_hat = 3.0_pReal*prm%b_tw(1)*mu/prm%L_tw & - + Gamma_sf/(3.0_pReal*prm%b_tw(1)) - x0 = mu*prm%b_sl(1)**2*(2.0_pReal+nu)/(Gamma_sf*8.0_pReal*PI*(1.0_pReal-nu)) - tau_r = mu*prm%b_sl(1)/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%x_c)+cos(PI/3.0_pReal)/x0) + tau_hat = 3.0_pREAL*prm%b_tw(1)*mu/prm%L_tw & + + Gamma_sf/(3.0_pREAL*prm%b_tw(1)) + x0 = mu*prm%b_sl(1)**2*(2.0_pREAL+nu)/(Gamma_sf*8.0_pREAL*PI*(1.0_pREAL-nu)) + tau_r = mu*prm%b_sl(1)/(2.0_pREAL*PI)*(1.0_pREAL/(x0+prm%x_c)+cos(PI/3.0_pREAL)/x0) do i = 1, prm%sum_N_tw tau = math_tensordot(Mp,prm%P_tw(1:3,1:3,i)) @@ -956,18 +956,18 @@ pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,& dP_dTau = prm%r(i) * (tau_hat/tau)**prm%r(i)/tau * P s = prm%fcc_twinNucleationSlipPair(1:2,i) - dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tw*3.0_pReal) + dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tw*3.0_pREAL) - P_ncs = 1.0_pReal-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) - dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal) + P_ncs = 1.0_pREAL-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) + dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pREAL) - V = PI/4.0_pReal*dst%Lambda_tw(i,en)**2*prm%t_tw(i) + V = PI/4.0_pREAL*dst%Lambda_tw(i,en)**2*prm%t_tw(i) dot_gamma_tw(i) = V*dot_N_0*P_ncs*P*prm%gamma_char_tw(i) if (present(ddot_gamma_dtau_tw)) & ddot_gamma_dtau_tw(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*prm%gamma_char_tw(i) else - dot_gamma_tw(i) = 0.0_pReal - if (present(ddot_gamma_dtau_tw)) ddot_gamma_dtau_tw(i) = 0.0_pReal + dot_gamma_tw(i) = 0.0_pREAL + if (present(ddot_gamma_dtau_tw)) ddot_gamma_dtau_tw(i) = 0.0_pREAL end if end do @@ -986,21 +986,21 @@ end subroutine kinetics_tw pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,& dot_gamma_tr,ddot_gamma_dtau_tr) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & T !< temperature integer, intent(in) :: & ph, & en - real(pReal), dimension(param(ph)%sum_N_sl), intent(in) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), intent(in) :: & abs_dot_gamma_sl - real(pReal), dimension(param(ph)%sum_N_tr), intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_tr), intent(out) :: & dot_gamma_tr - real(pReal), dimension(param(ph)%sum_N_tr), optional, intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_tr), optional, intent(out) :: & ddot_gamma_dtau_tr - real(pReal) :: & + real(pREAL) :: & tau, tau_r, tau_hat, & dot_N_0, & x0, V, & @@ -1019,10 +1019,10 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,& nu = elastic_nu(ph,en,prm%isotropic_bound) Gamma_sf = prm%Gamma_sf%at(T) - tau_hat = 3.0_pReal*prm%b_tr(1)*mu/prm%L_tr & - + (Gamma_sf + (prm%h/prm%V_mol - 2.0_pReal*prm%rho)*prm%Delta_G%at(T))/(3.0_pReal*prm%b_tr(1)) - x0 = mu*prm%b_sl(1)**2*(2.0_pReal+nu)/(Gamma_sf*8.0_pReal*PI*(1.0_pReal-nu)) - tau_r = mu*prm%b_sl(1)/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%x_c)+cos(PI/3.0_pReal)/x0) + tau_hat = 3.0_pREAL*prm%b_tr(1)*mu/prm%L_tr & + + (Gamma_sf + (prm%h/prm%V_mol - 2.0_pREAL*prm%rho)*prm%Delta_G%at(T))/(3.0_pREAL*prm%b_tr(1)) + x0 = mu*prm%b_sl(1)**2*(2.0_pREAL+nu)/(Gamma_sf*8.0_pREAL*PI*(1.0_pREAL-nu)) + tau_r = mu*prm%b_sl(1)/(2.0_pREAL*PI)*(1.0_pREAL/(x0+prm%x_c)+cos(PI/3.0_pREAL)/x0) do i = 1, prm%sum_N_tr tau = math_tensordot(Mp,prm%P_tr(1:3,1:3,i)) @@ -1032,18 +1032,18 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,& dP_dTau = prm%s(i) * (tau_hat/tau)**prm%s(i)/tau * P s = prm%fcc_twinNucleationSlipPair(1:2,i) - dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tr*3.0_pReal) + dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tr*3.0_pREAL) - P_ncs = 1.0_pReal-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) - dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal) + P_ncs = 1.0_pREAL-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) + dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pREAL) - V = PI/4.0_pReal*dst%Lambda_tr(i,en)**2*prm%t_tr(i) + V = PI/4.0_pREAL*dst%Lambda_tr(i,en)**2*prm%t_tr(i) dot_gamma_tr(i) = V*dot_N_0*P_ncs*P*gamma_char_tr if (present(ddot_gamma_dtau_tr)) & ddot_gamma_dtau_tr(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*gamma_char_tr else - dot_gamma_tr(i) = 0.0_pReal - if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_tr(i) = 0.0_pReal + dot_gamma_tr(i) = 0.0_pREAL + if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_tr(i) = 0.0_pREAL end if end do diff --git a/src/phase_mechanical_plastic_isotropic.f90 b/src/phase_mechanical_plastic_isotropic.f90 index c581776e7..eff65f9f3 100644 --- a/src/phase_mechanical_plastic_isotropic.f90 +++ b/src/phase_mechanical_plastic_isotropic.f90 @@ -10,7 +10,7 @@ submodule(phase:plastic) isotropic type :: tParameters - real(pReal) :: & + real(pREAL) :: & M, & !< Taylor factor dot_gamma_0, & !< reference strain rate n, & !< stress exponent @@ -30,7 +30,7 @@ submodule(phase:plastic) isotropic end type tParameters type :: tIsotropicState - real(pReal), pointer, dimension(:) :: & + real(pREAL), pointer, dimension(:) :: & xi end type tIsotropicState @@ -52,7 +52,7 @@ module function plastic_isotropic_init() result(myPlasticity) ph, & Nmembers, & sizeState, sizeDotState - real(pReal) :: & + real(pREAL) :: & xi_0 !< initial critical stress character(len=:), allocatable :: & refs, & @@ -103,24 +103,24 @@ module function plastic_isotropic_init() result(myPlasticity) prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0') prm%n = pl%get_asReal('n') prm%h_0 = pl%get_asReal('h_0') - prm%h = pl%get_asReal('h', defaultVal=3.0_pReal) ! match for fcc random polycrystal + prm%h = pl%get_asReal('h', defaultVal=3.0_pREAL) ! match for fcc random polycrystal prm%M = pl%get_asReal('M') - prm%h_ln = pl%get_asReal('h_ln', defaultVal=0.0_pReal) - prm%c_1 = pl%get_asReal('c_1', defaultVal=0.0_pReal) - prm%c_4 = pl%get_asReal('c_4', defaultVal=0.0_pReal) - prm%c_3 = pl%get_asReal('c_3', defaultVal=0.0_pReal) - prm%c_2 = pl%get_asReal('c_2', defaultVal=0.0_pReal) + prm%h_ln = pl%get_asReal('h_ln', defaultVal=0.0_pREAL) + prm%c_1 = pl%get_asReal('c_1', defaultVal=0.0_pREAL) + prm%c_4 = pl%get_asReal('c_4', defaultVal=0.0_pREAL) + prm%c_3 = pl%get_asReal('c_3', defaultVal=0.0_pREAL) + prm%c_2 = pl%get_asReal('c_2', defaultVal=0.0_pREAL) prm%a = pl%get_asReal('a') prm%dilatation = pl%get_asBool('dilatation',defaultVal = .false.) !-------------------------------------------------------------------------------------------------- ! sanity checks - if (xi_0 < 0.0_pReal) extmsg = trim(extmsg)//' xi_0' - if (prm%dot_gamma_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0' - if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' - if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' - if (prm%M <= 0.0_pReal) extmsg = trim(extmsg)//' M' + if (xi_0 < 0.0_pREAL) extmsg = trim(extmsg)//' xi_0' + if (prm%dot_gamma_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0' + if (prm%n <= 0.0_pREAL) extmsg = trim(extmsg)//' n' + if (prm%a <= 0.0_pREAL) extmsg = trim(extmsg)//' a' + if (prm%M <= 0.0_pREAL) extmsg = trim(extmsg)//' M' !-------------------------------------------------------------------------------------------------- ! allocate state arrays @@ -135,8 +135,8 @@ module function plastic_isotropic_init() result(myPlasticity) ! state aliases and initialization stt%xi => plasticState(ph)%state(1,:) stt%xi = xi_0 - plasticState(ph)%atol(1) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) - if (plasticState(ph)%atol(1) < 0.0_pReal) extmsg = trim(extmsg)//' atol_xi' + plasticState(ph)%atol(1) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL) + if (plasticState(ph)%atol(1) < 0.0_pREAL) extmsg = trim(extmsg)//' atol_xi' end associate @@ -154,20 +154,20 @@ end function plastic_isotropic_init !-------------------------------------------------------------------------------------------------- module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & Mp_dev !< deviatoric part of the Mandel stress - real(pReal) :: & + real(pREAL) :: & dot_gamma, & !< strainrate norm_Mp_dev, & !< norm of the deviatoric part of the Mandel stress squarenorm_Mp_dev !< square of the norm of the deviatoric part of the Mandel stress @@ -181,20 +181,20 @@ module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) squarenorm_Mp_dev = math_tensordot(Mp_dev,Mp_dev) norm_Mp_dev = sqrt(squarenorm_Mp_dev) - if (norm_Mp_dev > 0.0_pReal) then - dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(en)))**prm%n + if (norm_Mp_dev > 0.0_pREAL) then + dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pREAL) * norm_Mp_dev/(prm%M*stt%xi(en)))**prm%n Lp = dot_gamma * Mp_dev/norm_Mp_dev forall (k=1:3,l=1:3,m=1:3,n=1:3) & - dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev + dLp_dMp(k,l,m,n) = (prm%n-1.0_pREAL) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev forall (k=1:3,l=1:3) & - dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal + dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pREAL forall (k=1:3,m=1:3) & - dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pReal/3.0_pReal + dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pREAL/3.0_pREAL dLp_dMp = dot_gamma * dLp_dMp / norm_Mp_dev else - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL end if end associate @@ -207,18 +207,18 @@ end subroutine isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Li !< inleastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLi_dMi !< derivative of Li with respect to Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mi !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal) :: & + real(pREAL) :: & tr !< trace of spherical part of Mandel stress (= 3 x pressure) integer :: & k, l, m, n @@ -228,14 +228,14 @@ module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) tr=math_trace33(math_spherical33(Mi)) - if (prm%dilatation .and. abs(tr) > 0.0_pReal) then ! no stress or J2 plasticity --> Li and its derivative are zero + if (prm%dilatation .and. abs(tr) > 0.0_pREAL) then ! no stress or J2 plasticity --> Li and its derivative are zero Li = math_I3 & - * prm%dot_gamma_0 * (3.0_pReal*prm%M*stt%xi(en))**(-prm%n) & - * tr * abs(tr)**(prm%n-1.0_pReal) + * prm%dot_gamma_0 * (3.0_pREAL*prm%M*stt%xi(en))**(-prm%n) & + * tr * abs(tr)**(prm%n-1.0_pREAL) forall (k=1:3,l=1:3,m=1:3,n=1:3) dLi_dMi(k,l,m,n) = prm%n / tr * Li(k,l) * math_I3(m,n) else - Li = 0.0_pReal - dLi_dMi = 0.0_pReal + Li = 0.0_pREAL + dLi_dMi = 0.0_pREAL end if end associate @@ -248,15 +248,15 @@ module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) !-------------------------------------------------------------------------------------------------- module function isotropic_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState - real(pReal) :: & + real(pREAL) :: & dot_gamma, & !< strainrate xi_inf_star, & !< saturation xi norm_Mp !< norm of the (deviatoric) Mandel stress @@ -267,21 +267,21 @@ module function isotropic_dotState(Mp,ph,en) result(dotState) sqrt(math_tensordot(math_deviatoric33(Mp),math_deviatoric33(Mp))), & prm%dilatation) - dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(en))) **prm%n + dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pREAL) * norm_Mp /(prm%M*stt%xi(en))) **prm%n - if (dot_gamma > 1e-12_pReal) then + if (dot_gamma > 1e-12_pREAL) then if (dEq0(prm%c_1)) then xi_inf_star = prm%xi_inf else xi_inf_star = prm%xi_inf & - + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2))**(1.0_pReal / prm%c_3) & - / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) + + asinh( (dot_gamma / prm%c_1)**(1.0_pREAL / prm%c_2))**(1.0_pREAL / prm%c_3) & + / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pREAL / prm%n) end if dot_xi = dot_gamma & * ( prm%h_0 + prm%h_ln * log(dot_gamma) ) & - * sign(abs(1.0_pReal - stt%xi(en)/xi_inf_star)**prm%a *prm%h, 1.0_pReal-stt%xi(en)/xi_inf_star) + * sign(abs(1.0_pREAL - stt%xi(en)/xi_inf_star)**prm%a *prm%h, 1.0_pREAL-stt%xi(en)/xi_inf_star) else - dot_xi = 0.0_pReal + dot_xi = 0.0_pREAL end if end associate diff --git a/src/phase_mechanical_plastic_kinehardening.f90 b/src/phase_mechanical_plastic_kinehardening.f90 index d4bd41164..ad2543b83 100644 --- a/src/phase_mechanical_plastic_kinehardening.f90 +++ b/src/phase_mechanical_plastic_kinehardening.f90 @@ -8,10 +8,10 @@ submodule(phase:plastic) kinehardening type :: tParameters - real(pReal) :: & - n = 1.0_pReal, & !< stress exponent for slip - dot_gamma_0 = 1.0_pReal !< reference shear strain rate for slip - real(pReal), allocatable, dimension(:) :: & + real(pREAL) :: & + n = 1.0_pREAL, & !< stress exponent for slip + dot_gamma_0 = 1.0_pREAL !< reference shear strain rate for slip + real(pREAL), allocatable, dimension(:) :: & h_0_xi, & !< initial hardening rate of forest stress per slip family !! θ_0,for h_0_chi, & !< initial hardening rate of back stress per slip family @@ -22,9 +22,9 @@ submodule(phase:plastic) kinehardening !! θ_1,bs xi_inf, & !< back-extrapolated forest stress from terminal linear hardening chi_inf !< back-extrapolated back stress from terminal linear hardening - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & h_sl_sl !< slip resistance change per slip activity - real(pReal), allocatable, dimension(:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:) :: & P, & P_nS_pos, & P_nS_neg @@ -46,7 +46,7 @@ submodule(phase:plastic) kinehardening end type tIndexDotState type :: tKinehardeningState - real(pReal), pointer, dimension(:,:) :: & + real(pREAL), pointer, dimension(:,:) :: & xi, & !< forest stress !! τ_for chi, & !< back stress @@ -82,7 +82,7 @@ module function plastic_kinehardening_init() result(myPlasticity) startIndex, endIndex integer, dimension(:), allocatable :: & N_sl - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & xi_0, & !< initial forest stress !! τ_for,0 a !< non-Schmid coefficients @@ -175,11 +175,11 @@ module function plastic_kinehardening_init() result(myPlasticity) !-------------------------------------------------------------------------------------------------- ! sanity checks - if ( prm%dot_gamma_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0' - if ( prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' - if (any(xi_0 <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_0' - if (any(prm%xi_inf <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_inf' - if (any(prm%chi_inf <= 0.0_pReal)) extmsg = trim(extmsg)//' chi_inf' + if ( prm%dot_gamma_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0' + if ( prm%n <= 0.0_pREAL) extmsg = trim(extmsg)//' n' + if (any(xi_0 <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_0' + if (any(prm%xi_inf <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_inf' + if (any(prm%chi_inf <= 0.0_pREAL)) extmsg = trim(extmsg)//' chi_inf' else slipActive xi_0 = emptyRealArray @@ -208,21 +208,21 @@ module function plastic_kinehardening_init() result(myPlasticity) idx_dot%xi = [startIndex,endIndex] stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi = spread(xi_0, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%chi = [startIndex,endIndex] stt%chi => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma = [startIndex,endIndex] stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma' o = plasticState(ph)%offsetDeltaState startIndex = endIndex + 1 @@ -257,12 +257,12 @@ end function plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & @@ -270,12 +270,12 @@ pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) integer :: & i,k,l,m,n - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos,dot_gamma_neg, & ddot_gamma_dtau_pos,ddot_gamma_dtau_neg - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL associate(prm => param(ph)) @@ -299,17 +299,17 @@ end subroutine kinehardening_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState - real(pReal) :: & + real(pREAL) :: & sumGamma - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos,dot_gamma_neg @@ -326,14 +326,14 @@ module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState) dot_xi = matmul(prm%h_sl_sl,dot_gamma) & * ( prm%h_inf_xi & + ( prm%h_0_xi & - - prm%h_inf_xi * (1_pReal -sumGamma*prm%h_0_xi/prm%xi_inf) ) & + - prm%h_inf_xi * (1_pREAL -sumGamma*prm%h_0_xi/prm%xi_inf) ) & * exp(-sumGamma*prm%h_0_xi/prm%xi_inf) & ) dot_chi = stt%sgn_gamma(:,en)*dot_gamma & * ( prm%h_inf_chi & + ( prm%h_0_chi & - - prm%h_inf_chi*(1_pReal -(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) ) & + - prm%h_inf_chi*(1_pREAL -(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) ) & * exp(-(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) & ) @@ -347,13 +347,13 @@ end function plastic_kinehardening_dotState !-------------------------------------------------------------------------------------------------- module subroutine plastic_kinehardening_deltaState(Mp,ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos,dot_gamma_neg, & sgn_gamma @@ -362,17 +362,17 @@ module subroutine plastic_kinehardening_deltaState(Mp,ph,en) call kinetics(Mp,ph,en, dot_gamma_pos,dot_gamma_neg) sgn_gamma = merge(state(ph)%sgn_gamma(:,en), & - sign(1.0_pReal,dot_gamma_pos+dot_gamma_neg), & - dEq0(dot_gamma_pos+dot_gamma_neg,1e-10_pReal)) + sign(1.0_pREAL,dot_gamma_pos+dot_gamma_neg), & + dEq0(dot_gamma_pos+dot_gamma_neg,1e-10_pREAL)) - where(dNeq(sgn_gamma,stt%sgn_gamma(:,en),0.1_pReal)) ! ToDo sgn_gamma*stt%sgn_gamma(:,en)<0 + where(dNeq(sgn_gamma,stt%sgn_gamma(:,en),0.1_pREAL)) ! ToDo sgn_gamma*stt%sgn_gamma(:,en)<0 dlt%sgn_gamma (:,en) = sgn_gamma - stt%sgn_gamma (:,en) dlt%chi_flip (:,en) = abs(stt%chi (:,en)) - stt%chi_flip (:,en) dlt%gamma_flip(:,en) = stt%gamma(:,en) - stt%gamma_flip(:,en) else where - dlt%sgn_gamma (:,en) = 0.0_pReal - dlt%chi_flip (:,en) = 0.0_pReal - dlt%gamma_flip(:,en) = 0.0_pReal + dlt%sgn_gamma (:,en) = 0.0_pREAL + dlt%chi_flip (:,en) = 0.0_pREAL + dlt%gamma_flip(:,en) = 0.0_pREAL end where end associate @@ -434,20 +434,20 @@ end subroutine plastic_kinehardening_result pure subroutine kinetics(Mp,ph,en, & dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: & dot_gamma_pos, & dot_gamma_neg - real(pReal), intent(out), dimension(param(ph)%sum_N_sl), optional :: & + real(pREAL), intent(out), dimension(param(ph)%sum_N_sl), optional :: & ddot_gamma_dtau_pos, & ddot_gamma_dtau_neg - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau_pos, & tau_neg integer :: i @@ -458,35 +458,35 @@ pure subroutine kinetics(Mp,ph,en, & do i = 1, prm%sum_N_sl tau_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i)) - stt%chi(i,en) tau_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)) - stt%chi(i,en), & - 0.0_pReal, prm%nonSchmidActive) + 0.0_pREAL, prm%nonSchmidActive) end do where(dNeq0(tau_pos)) - dot_gamma_pos = prm%dot_gamma_0 * merge(0.5_pReal,1.0_pReal, prm%nonSchmidActive) & ! 1/2 if non-Schmid active + dot_gamma_pos = prm%dot_gamma_0 * merge(0.5_pREAL,1.0_pREAL, prm%nonSchmidActive) & ! 1/2 if non-Schmid active * sign(abs(tau_pos/stt%xi(:,en))**prm%n, tau_pos) else where - dot_gamma_pos = 0.0_pReal + dot_gamma_pos = 0.0_pREAL end where where(dNeq0(tau_neg)) - dot_gamma_neg = prm%dot_gamma_0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 + dot_gamma_neg = prm%dot_gamma_0 * 0.5_pREAL & ! only used if non-Schmid active, always 1/2 * sign(abs(tau_neg/stt%xi(:,en))**prm%n, tau_neg) else where - dot_gamma_neg = 0.0_pReal + dot_gamma_neg = 0.0_pREAL end where if (present(ddot_gamma_dtau_pos)) then where(dNeq0(dot_gamma_pos)) ddot_gamma_dtau_pos = dot_gamma_pos*prm%n/tau_pos else where - ddot_gamma_dtau_pos = 0.0_pReal + ddot_gamma_dtau_pos = 0.0_pREAL end where end if if (present(ddot_gamma_dtau_neg)) then where(dNeq0(dot_gamma_neg)) ddot_gamma_dtau_neg = dot_gamma_neg*prm%n/tau_neg else where - ddot_gamma_dtau_neg = 0.0_pReal + ddot_gamma_dtau_neg = 0.0_pREAL end where end if diff --git a/src/phase_mechanical_plastic_nonlocal.f90 b/src/phase_mechanical_plastic_nonlocal.f90 index f67e383e3..d50f562ca 100644 --- a/src/phase_mechanical_plastic_nonlocal.f90 +++ b/src/phase_mechanical_plastic_nonlocal.f90 @@ -14,10 +14,10 @@ submodule(phase:plastic) nonlocal geometry_plastic_nonlocal_disable type :: tGeometry - real(pReal), dimension(:), allocatable :: V_0 + real(pREAL), dimension(:), allocatable :: V_0 integer, dimension(:,:,:), allocatable :: IPneighborhood - real(pReal), dimension(:,:), allocatable :: IParea, IPcoordinates - real(pReal), dimension(:,:,:), allocatable :: IPareaNormal + real(pREAL), dimension(:,:), allocatable :: IParea, IPcoordinates + real(pREAL), dimension(:,:,:), allocatable :: IPareaNormal end type tGeometry type(tGeometry), dimension(:), allocatable :: geom @@ -48,15 +48,15 @@ submodule(phase:plastic) nonlocal iD !< state indices for stable dipole height !END DEPRECATED - real(pReal), dimension(:,:,:,:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:,:,:,:), allocatable :: & compatibility !< slip system compatibility between en and my neighbors type :: tInitialParameters !< container type for internal constitutive parameters - real(pReal) :: & + real(pREAL) :: & sigma_rho_u, & !< standard deviation of scatter in initial dislocation density random_rho_u, & random_rho_u_binning - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & rho_u_ed_pos_0, & !< initial edge_pos dislocation density rho_u_ed_neg_0, & !< initial edge_neg dislocation density rho_u_sc_pos_0, & !< initial screw_pos dislocation density @@ -68,7 +68,7 @@ submodule(phase:plastic) nonlocal end type tInitialParameters type :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & + real(pREAL) :: & V_at, & !< atomic volume D_0, & !< prefactor for self-diffusion coefficient Q_cl, & !< activation enthalpy for diffusion @@ -91,14 +91,14 @@ submodule(phase:plastic) nonlocal f_ed, & mu, & nu - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & d_ed, & !< minimum stable edge dipole height d_sc, & !< minimum stable screw dipole height tau_Peierls_ed, & tau_Peierls_sc, & i_sl, & !< mean free path prefactor for each b_sl !< absolute length of Burgers vector [m] - real(pReal), dimension(:,:), allocatable :: & + real(pREAL), dimension(:,:), allocatable :: & slip_normal, & slip_direction, & slip_transverse, & @@ -107,7 +107,7 @@ submodule(phase:plastic) nonlocal h_sl_sl ,& !< coefficients for slip-slip interaction forestProjection_Edge, & !< matrix of forest projections of edge dislocations forestProjection_Screw !< matrix of forest projections of screw dislocations - real(pReal), dimension(:,:,:), allocatable :: & + real(pREAL), dimension(:,:,:), allocatable :: & P_sl, & !< Schmid contribution P_nS_pos, & P_nS_neg !< combined projection of Schmid and non-Schmid contributions to the resolved shear stress (only for screws) @@ -127,15 +127,15 @@ submodule(phase:plastic) nonlocal end type tParameters type :: tNonlocalDependentState - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & tau_pass, & tau_Back - real(pReal), allocatable, dimension(:,:,:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:,:,:) :: & compatibility end type tNonlocalDependentState type :: tNonlocalState - real(pReal), pointer, dimension(:,:) :: & + real(pREAL), pointer, dimension(:,:) :: & rho, & ! < all dislocations rhoSgl, & rhoSglMobile, & ! iRhoU @@ -186,7 +186,7 @@ module function plastic_nonlocal_init() result(myPlasticity) sizeState, sizeDotState, sizeDependentState, sizeDeltaState, & s1, s2, & s, t, l - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & a character(len=:), allocatable :: & refs, & @@ -248,7 +248,7 @@ module function plastic_nonlocal_init() result(myPlasticity) plasticState(ph)%nonlocal = pl%get_asBool('flux',defaultVal=.True.) prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain') - prm%atol_rho = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) + prm%atol_rho = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL) ini%N_sl = pl%get_as1dInt('N_sl',defaultVal=emptyIntArray) prm%sum_N_sl = sum(abs(ini%N_sl)) @@ -318,8 +318,8 @@ module function plastic_nonlocal_init() result(myPlasticity) prm%peierlsstress(:,2) = prm%tau_Peierls_sc prm%rho_significant = pl%get_asReal('rho_significant') - prm%rho_min = pl%get_asReal('rho_min', 0.0_pReal) - prm%C_CFL = pl%get_asReal('C_CFL',defaultVal=2.0_pReal) + prm%rho_min = pl%get_asReal('rho_min', 0.0_pREAL) + prm%C_CFL = pl%get_asReal('C_CFL',defaultVal=2.0_pREAL) prm%V_at = pl%get_asReal('V_at') prm%D_0 = pl%get_asReal('D_0') @@ -338,62 +338,62 @@ module function plastic_nonlocal_init() result(myPlasticity) ! ToDo: discuss logic ini%sigma_rho_u = pl%get_asReal('sigma_rho_u') - ini%random_rho_u = pl%get_asReal('random_rho_u',defaultVal= 0.0_pReal) + ini%random_rho_u = pl%get_asReal('random_rho_u',defaultVal= 0.0_pREAL) if (pl%contains('random_rho_u')) & - ini%random_rho_u_binning = pl%get_asReal('random_rho_u_binning',defaultVal=0.0_pReal) !ToDo: useful default? - ! if (rhoSglRandom(instance) < 0.0_pReal) & - ! if (rhoSglRandomBinning(instance) <= 0.0_pReal) & + ini%random_rho_u_binning = pl%get_asReal('random_rho_u_binning',defaultVal=0.0_pREAL) !ToDo: useful default? + ! if (rhoSglRandom(instance) < 0.0_pREAL) & + ! if (rhoSglRandomBinning(instance) <= 0.0_pREAL) & - prm%chi_surface = pl%get_asReal('chi_surface',defaultVal=1.0_pReal) - prm%chi_GB = pl%get_asReal('chi_GB', defaultVal=-1.0_pReal) + prm%chi_surface = pl%get_asReal('chi_surface',defaultVal=1.0_pREAL) + prm%chi_GB = pl%get_asReal('chi_GB', defaultVal=-1.0_pREAL) prm%f_ed_mult = pl%get_asReal('f_ed_mult') prm%shortRangeStressCorrection = pl%get_asBool('short_range_stress_correction', defaultVal = .false.) !-------------------------------------------------------------------------------------------------- ! sanity checks - if (any(prm%b_sl < 0.0_pReal)) extmsg = trim(extmsg)//' b_sl' - if (any(prm%i_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' i_sl' + if (any(prm%b_sl < 0.0_pREAL)) extmsg = trim(extmsg)//' b_sl' + if (any(prm%i_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' i_sl' - if (any(ini%rho_u_ed_pos_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_u_ed_pos_0' - if (any(ini%rho_u_ed_neg_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_u_ed_neg_0' - if (any(ini%rho_u_sc_pos_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_u_sc_pos_0' - if (any(ini%rho_u_sc_neg_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_u_sc_neg_0' - if (any(ini%rho_d_ed_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_d_ed_0' - if (any(ini%rho_d_sc_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_d_sc_0' + if (any(ini%rho_u_ed_pos_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_u_ed_pos_0' + if (any(ini%rho_u_ed_neg_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_u_ed_neg_0' + if (any(ini%rho_u_sc_pos_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_u_sc_pos_0' + if (any(ini%rho_u_sc_neg_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_u_sc_neg_0' + if (any(ini%rho_d_ed_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_d_ed_0' + if (any(ini%rho_d_sc_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_d_sc_0' - if (any(prm%peierlsstress < 0.0_pReal)) extmsg = trim(extmsg)//' tau_peierls' - if (any(prm%minDipoleHeight < 0.0_pReal)) extmsg = trim(extmsg)//' d_ed or d_sc' + if (any(prm%peierlsstress < 0.0_pREAL)) extmsg = trim(extmsg)//' tau_peierls' + if (any(prm%minDipoleHeight < 0.0_pREAL)) extmsg = trim(extmsg)//' d_ed or d_sc' - if (prm%B < 0.0_pReal) extmsg = trim(extmsg)//' B' - if (prm%Q_cl < 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' - if (prm%nu_a <= 0.0_pReal) extmsg = trim(extmsg)//' nu_a' - if (prm%w <= 0.0_pReal) extmsg = trim(extmsg)//' w' - if (prm%D_0 < 0.0_pReal) extmsg = trim(extmsg)//' D_0' - if (prm%V_at <= 0.0_pReal) extmsg = trim(extmsg)//' V_at' ! ToDo: in dislotungsten, the atomic volume is given as a factor + if (prm%B < 0.0_pREAL) extmsg = trim(extmsg)//' B' + if (prm%Q_cl < 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl' + if (prm%nu_a <= 0.0_pREAL) extmsg = trim(extmsg)//' nu_a' + if (prm%w <= 0.0_pREAL) extmsg = trim(extmsg)//' w' + if (prm%D_0 < 0.0_pREAL) extmsg = trim(extmsg)//' D_0' + if (prm%V_at <= 0.0_pREAL) extmsg = trim(extmsg)//' V_at' ! ToDo: in dislotungsten, the atomic volume is given as a factor - if (prm%rho_min < 0.0_pReal) extmsg = trim(extmsg)//' rho_min' - if (prm%rho_significant < 0.0_pReal) extmsg = trim(extmsg)//' rho_significant' - if (prm%atol_rho < 0.0_pReal) extmsg = trim(extmsg)//' atol_rho' - if (prm%C_CFL < 0.0_pReal) extmsg = trim(extmsg)//' C_CFL' + if (prm%rho_min < 0.0_pREAL) extmsg = trim(extmsg)//' rho_min' + if (prm%rho_significant < 0.0_pREAL) extmsg = trim(extmsg)//' rho_significant' + if (prm%atol_rho < 0.0_pREAL) extmsg = trim(extmsg)//' atol_rho' + if (prm%C_CFL < 0.0_pREAL) extmsg = trim(extmsg)//' C_CFL' - if (prm%p <= 0.0_pReal .or. prm%p > 1.0_pReal) extmsg = trim(extmsg)//' p_sl' - if (prm%q < 1.0_pReal .or. prm%q > 2.0_pReal) extmsg = trim(extmsg)//' q_sl' + if (prm%p <= 0.0_pREAL .or. prm%p > 1.0_pREAL) extmsg = trim(extmsg)//' p_sl' + if (prm%q < 1.0_pREAL .or. prm%q > 2.0_pREAL) extmsg = trim(extmsg)//' q_sl' - if (prm%f_F < 0.0_pReal .or. prm%f_F > 1.0_pReal) & + if (prm%f_F < 0.0_pREAL .or. prm%f_F > 1.0_pREAL) & extmsg = trim(extmsg)//' f_F' - if (prm%f_ed < 0.0_pReal .or. prm%f_ed > 1.0_pReal) & + if (prm%f_ed < 0.0_pREAL .or. prm%f_ed > 1.0_pREAL) & extmsg = trim(extmsg)//' f_ed' - if (prm%Q_sol <= 0.0_pReal) extmsg = trim(extmsg)//' Q_sol' - if (prm%f_sol <= 0.0_pReal) extmsg = trim(extmsg)//' f_sol' - if (prm%c_sol <= 0.0_pReal) extmsg = trim(extmsg)//' c_sol' + if (prm%Q_sol <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_sol' + if (prm%f_sol <= 0.0_pREAL) extmsg = trim(extmsg)//' f_sol' + if (prm%c_sol <= 0.0_pREAL) extmsg = trim(extmsg)//' c_sol' - if (prm%chi_GB > 1.0_pReal) extmsg = trim(extmsg)//' chi_GB' - if (prm%chi_surface < 0.0_pReal .or. prm%chi_surface > 1.0_pReal) & + if (prm%chi_GB > 1.0_pREAL) extmsg = trim(extmsg)//' chi_GB' + if (prm%chi_surface < 0.0_pREAL .or. prm%chi_surface > 1.0_pREAL) & extmsg = trim(extmsg)//' chi_surface' - if (prm%f_ed_mult < 0.0_pReal .or. prm%f_ed_mult > 1.0_pReal) & + if (prm%f_ed_mult < 0.0_pREAL .or. prm%f_ed_mult > 1.0_pREAL) & extmsg = trim(extmsg)//' f_ed_mult' end if slipActive @@ -491,8 +491,8 @@ module function plastic_nonlocal_init() result(myPlasticity) stt%gamma => plasticState(ph)%state (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) dot%gamma => plasticState(ph)%dotState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) del%gamma => plasticState(ph)%deltaState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) - plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asReal('atol_gamma', defaultVal = 1.0e-6_pReal) - if (any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) & + plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asReal('atol_gamma', defaultVal = 1.0e-6_pREAL) + if (any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pREAL)) & extmsg = trim(extmsg)//' atol_gamma' stt%rho_forest => plasticState(ph)%state (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:Nmembers) @@ -502,9 +502,9 @@ module function plastic_nonlocal_init() result(myPlasticity) stt%v_scr_pos => plasticState(ph)%state (14*prm%sum_N_sl + 1:15*prm%sum_N_sl,1:Nmembers) stt%v_scr_neg => plasticState(ph)%state (15*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:Nmembers) - allocate(dst%tau_pass(prm%sum_N_sl,Nmembers),source=0.0_pReal) - allocate(dst%tau_back(prm%sum_N_sl,Nmembers),source=0.0_pReal) - allocate(dst%compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nIPneighbors,Nmembers),source=0.0_pReal) + allocate(dst%tau_pass(prm%sum_N_sl,Nmembers),source=0.0_pREAL) + allocate(dst%tau_back(prm%sum_N_sl,Nmembers),source=0.0_pREAL) + allocate(dst%compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nIPneighbors,Nmembers),source=0.0_pREAL) end associate if (Nmembers > 0) call stateInit(ini,ph,Nmembers) @@ -516,7 +516,7 @@ module function plastic_nonlocal_init() result(myPlasticity) end do allocate(compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nIPneighbors,& - discretization_nIPs,discretization_Nelems), source=0.0_pReal) + discretization_nIPs,discretization_Nelems), source=0.0_pREAL) ! BEGIN DEPRECATED---------------------------------------------------------------------------------- allocate(iRhoU(maxval(param%sum_N_sl),4,phases%length), source=0) @@ -573,45 +573,45 @@ module subroutine nonlocal_dependentState(ph, en) s, & ! slip system index dir, & n - real(pReal) :: & + real(pREAL) :: & FVsize, & nRealNeighbors, & ! number of really existing neighbors mu, & nu integer, dimension(2) :: & neighbors - real(pReal), dimension(2) :: & + real(pREAL), dimension(2) :: & rhoExcessGradient, & rhoExcessGradient_over_rho, & rhoTotal - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & rhoExcessDifferences, & normal_latticeConf - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & invFe, & !< inverse of elastic deformation gradient invFp, & !< inverse of plastic deformation gradient connections, & invConnections - real(pReal), dimension(3,nIPneighbors) :: & + real(pREAL), dimension(3,nIPneighbors) :: & connection_latticeConf - real(pReal), dimension(2,param(ph)%sum_N_sl) :: & + real(pREAL), dimension(2,param(ph)%sum_N_sl) :: & rhoExcess - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & rho_edg_delta, & rho_scr_delta - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & rho, & rho0, & rho_neighbor0 - real(pReal), dimension(param(ph)%sum_N_sl,param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,param(ph)%sum_N_sl) :: & myInteractionMatrix ! corrected slip interaction matrix - real(pReal), dimension(param(ph)%sum_N_sl,nIPneighbors) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,nIPneighbors) :: & rho_edg_delta_neighbor, & rho_scr_delta_neighbor - real(pReal), dimension(2,maxval(param%sum_N_sl),nIPneighbors) :: & + real(pREAL), dimension(2,maxval(param%sum_N_sl),nIPneighbors) :: & neighbor_rhoExcess, & ! excess density at neighboring material point neighbor_rhoTotal ! total density at neighboring material point - real(pReal), dimension(3,param(ph)%sum_N_sl,2) :: & + real(pREAL), dimension(3,param(ph)%sum_N_sl,2) :: & m ! direction of dislocation motion associate(prm => param(ph),dst => dependentState(ph), stt => state(ph)) @@ -628,10 +628,10 @@ module subroutine nonlocal_dependentState(ph, en) ! (see Kubin,Devincre,Hoc; 2008; Modeling dislocation storage rates and mean free paths in face-centered cubic crystals) if (any(phase_lattice(ph) == ['cI','cF'])) then myInteractionMatrix = prm%h_sl_sl & - * spread(( 1.0_pReal - prm%f_F & + * spread(( 1.0_pREAL - prm%f_F & + prm%f_F & - * log(0.35_pReal * prm%b_sl * sqrt(max(stt%rho_forest(:,en),prm%rho_significant))) & - / log(0.35_pReal * prm%b_sl * 1e6_pReal))**2,2,prm%sum_N_sl) + * log(0.35_pREAL * prm%b_sl * sqrt(max(stt%rho_forest(:,en),prm%rho_significant))) & + / log(0.35_pREAL * prm%b_sl * 1e6_pREAL))**2,2,prm%sum_N_sl) else myInteractionMatrix = prm%h_sl_sl end if @@ -657,12 +657,12 @@ module subroutine nonlocal_dependentState(ph, en) rhoExcess(1,:) = rho_edg_delta rhoExcess(2,:) = rho_scr_delta - FVsize = geom(ph)%V_0(en)**(1.0_pReal/3.0_pReal) + FVsize = geom(ph)%V_0(en)**(1.0_pREAL/3.0_pREAL) !* loop through my neighborhood and get the connection vectors (in lattice frame) and the excess densities - nRealNeighbors = 0.0_pReal - neighbor_rhoTotal = 0.0_pReal + nRealNeighbors = 0.0_pREAL + neighbor_rhoTotal = 0.0_pREAL do n = 1,nIPneighbors neighbor_el = geom(ph)%IPneighborhood(1,n,en) neighbor_ip = geom(ph)%IPneighborhood(2,n,en) @@ -670,7 +670,7 @@ module subroutine nonlocal_dependentState(ph, en) if (neighbor_el > 0 .and. neighbor_ip > 0) then if (material_ID_phase(1,(neighbor_el-1)*discretization_nIPs + neighbor_ip) == ph) then no = material_entry_phase(1,(neighbor_el-1)*discretization_nIPs + neighbor_ip) - nRealNeighbors = nRealNeighbors + 1.0_pReal + nRealNeighbors = nRealNeighbors + 1.0_pREAL rho_neighbor0 = getRho0(ph,no) rho_edg_delta_neighbor(:,n) = rho_neighbor0(:,mob_edg_pos) - rho_neighbor0(:,mob_edg_neg) @@ -682,17 +682,17 @@ module subroutine nonlocal_dependentState(ph, en) connection_latticeConf(1:3,n) = matmul(invFe, geom(ph)%IPcoordinates(1:3,no) & - geom(ph)%IPcoordinates(1:3,en)) normal_latticeConf = matmul(transpose(invFp), geom(ph)%IPareaNormal(1:3,n,en)) - if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) & ! neighboring connection points in opposite direction to face normal: must be periodic image + if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pREAL) & ! neighboring connection points in opposite direction to face normal: must be periodic image connection_latticeConf(1:3,n) = normal_latticeConf * geom(ph)%V_0(en)/geom(ph)%IParea(n,en) ! instead take the surface normal scaled with the diameter of the cell else ! local neighbor or different lattice structure or different constitution instance -> use central values instead - connection_latticeConf(1:3,n) = 0.0_pReal + connection_latticeConf(1:3,n) = 0.0_pREAL rho_edg_delta_neighbor(:,n) = rho_edg_delta rho_scr_delta_neighbor(:,n) = rho_scr_delta end if else ! free surface -> use central values instead - connection_latticeConf(1:3,n) = 0.0_pReal + connection_latticeConf(1:3,n) = 0.0_pREAL rho_edg_delta_neighbor(:,n) = rho_edg_delta rho_scr_delta_neighbor(:,n) = rho_scr_delta end if @@ -730,15 +730,15 @@ module subroutine nonlocal_dependentState(ph, en) rhoExcessGradient(2) = rhoExcessGradient(2) + sum(rho(s,imm_scr)) / FVsize ! ... normalized with the total density ... - rhoTotal(1) = (sum(abs(rho(s,edg))) + sum(neighbor_rhoTotal(1,s,:))) / (1.0_pReal + nRealNeighbors) - rhoTotal(2) = (sum(abs(rho(s,scr))) + sum(neighbor_rhoTotal(2,s,:))) / (1.0_pReal + nRealNeighbors) + rhoTotal(1) = (sum(abs(rho(s,edg))) + sum(neighbor_rhoTotal(1,s,:))) / (1.0_pREAL + nRealNeighbors) + rhoTotal(2) = (sum(abs(rho(s,scr))) + sum(neighbor_rhoTotal(2,s,:))) / (1.0_pREAL + nRealNeighbors) - rhoExcessGradient_over_rho = 0.0_pReal - where(rhoTotal > 0.0_pReal) rhoExcessGradient_over_rho = rhoExcessGradient / rhoTotal + rhoExcessGradient_over_rho = 0.0_pREAL + where(rhoTotal > 0.0_pREAL) rhoExcessGradient_over_rho = rhoExcessGradient / rhoTotal ! ... gives the local stress correction when multiplied with a factor - dst%tau_back(s,en) = - mu * prm%b_sl(s) / (2.0_pReal * PI) & - * ( rhoExcessGradient_over_rho(1) / (1.0_pReal - nu) & + dst%tau_back(s,en) = - mu * prm%b_sl(s) / (2.0_pREAL * PI) & + * ( rhoExcessGradient_over_rho(1) / (1.0_pREAL - nu) & + rhoExcessGradient_over_rho(2)) end do end if @@ -753,39 +753,39 @@ end subroutine nonlocal_dependentState !-------------------------------------------------------------------------------------------------- module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp, & Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp integer, intent(in) :: & ph, & en - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< derivative of Lp with respect to Mp integer :: & i, j, k, l, & t, & !< dislocation type s !< index of my current slip system - real(pReal), dimension(param(ph)%sum_N_sl,8) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,8) :: & rhoSgl !< single dislocation densities (including blocked) - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & rho - real(pReal), dimension(param(ph)%sum_N_sl,4) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,4) :: & v, & !< velocity tauNS, & !< resolved shear stress including non Schmid and backstress terms dv_dtau, & !< velocity derivative with respect to the shear stress dv_dtauNS !< velocity derivative with respect to the shear stress - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau, & !< resolved shear stress including backstress terms dot_gamma !< shear rate - real(pReal) :: & + real(pREAL) :: & Temperature !< temperature Temperature = thermal_T(ph,en) - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL associate(prm => param(ph),dst=>dependentState(ph),stt=>state(ph)) @@ -797,7 +797,7 @@ module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp, & tau(s) = math_tensordot(Mp, prm%P_sl(1:3,1:3,s)) tauNS(s,1) = tau(s) tauNS(s,2) = tau(s) - if (tau(s) > 0.0_pReal) then + if (tau(s) > 0.0_pREAL) then tauNS(s,3) = math_tensordot(Mp, +prm%P_nS_pos(1:3,1:3,s)) tauNS(s,4) = math_tensordot(Mp, -prm%P_nS_neg(1:3,1:3,s)) else @@ -830,7 +830,7 @@ module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp, & stt%v(:,en) = pack(v,.true.) !*** Bauschinger effect - forall (s = 1:prm%sum_N_sl, t = 5:8, rhoSgl(s,t) * v(s,t-4) < 0.0_pReal) & + forall (s = 1:prm%sum_N_sl, t = 5:8, rhoSgl(s,t) * v(s,t-4) < 0.0_pREAL) & rhoSgl(s,t-4) = rhoSgl(s,t-4) + abs(rhoSgl(s,t)) dot_gamma = sum(rhoSgl(:,1:4) * v, 2) * prm%b_sl @@ -856,7 +856,7 @@ end subroutine nonlocal_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module subroutine plastic_nonlocal_deltaState(Mp,ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< MandelStress integer, intent(in) :: & ph, & @@ -866,19 +866,19 @@ module subroutine plastic_nonlocal_deltaState(Mp,ph,en) c, & ! character of dislocation t, & ! type of dislocation s ! index of my current slip system - real(pReal) :: & + real(pREAL) :: & mu, & nu - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & deltaRhoRemobilization, & ! density increment by remobilization deltaRhoDipole2SingleStress ! density increment by dipole dissociation (by stress change) - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & rho ! current dislocation densities - real(pReal), dimension(param(ph)%sum_N_sl,4) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,4) :: & v ! dislocation glide velocity - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau ! current resolved shear stress - real(pReal), dimension(param(ph)%sum_N_sl,2) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,2) :: & rhoDip, & ! current dipole dislocation densities (screw and edge dipoles) dUpper, & ! current maximum stable dipole distance for edges and screws dUpperOld, & ! old maximum stable dipole distance for edges and screws @@ -899,16 +899,16 @@ module subroutine plastic_nonlocal_deltaState(Mp,ph,en) !**************************************************************************** !*** dislocation remobilization (bauschinger effect) - where(rho(:,imm) * v < 0.0_pReal) + where(rho(:,imm) * v < 0.0_pREAL) deltaRhoRemobilization(:,mob) = abs(rho(:,imm)) deltaRhoRemobilization(:,imm) = - rho(:,imm) rho(:,mob) = rho(:,mob) + abs(rho(:,imm)) - rho(:,imm) = 0.0_pReal + rho(:,imm) = 0.0_pREAL elsewhere - deltaRhoRemobilization(:,mob) = 0.0_pReal - deltaRhoRemobilization(:,imm) = 0.0_pReal + deltaRhoRemobilization(:,mob) = 0.0_pREAL + deltaRhoRemobilization(:,imm) = 0.0_pREAL endwhere - deltaRhoRemobilization(:,dip) = 0.0_pReal + deltaRhoRemobilization(:,dip) = 0.0_pREAL !**************************************************************************** !*** calculate dipole formation and dissociation by stress change @@ -916,32 +916,32 @@ module subroutine plastic_nonlocal_deltaState(Mp,ph,en) !*** calculate limits for stable dipole height do s = 1,prm%sum_N_sl tau(s) = math_tensordot(Mp, prm%P_sl(1:3,1:3,s)) +dst%tau_back(s,en) - if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal + if (abs(tau(s)) < 1.0e-15_pREAL) tau(s) = 1.0e-15_pREAL end do - dUpper(:,1) = mu * prm%b_sl/(8.0_pReal * PI * (1.0_pReal - nu) * abs(tau)) - dUpper(:,2) = mu * prm%b_sl/(4.0_pReal * PI * abs(tau)) + dUpper(:,1) = mu * prm%b_sl/(8.0_pREAL * PI * (1.0_pREAL - nu) * abs(tau)) + dUpper(:,2) = mu * prm%b_sl/(4.0_pREAL * PI * abs(tau)) where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) & - dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1)) + dUpper(:,1) = min(1.0_pREAL/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1)) where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) & - dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2)) + dUpper(:,2) = min(1.0_pREAL/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2)) dUpper = max(dUpper,prm%minDipoleHeight) deltaDUpper = dUpper - dUpperOld !*** dissociation by stress increase - deltaRhoDipole2SingleStress = 0.0_pReal - forall (c=1:2, s=1:prm%sum_N_sl, deltaDUpper(s,c) < 0.0_pReal .and. & + deltaRhoDipole2SingleStress = 0.0_pREAL + forall (c=1:2, s=1:prm%sum_N_sl, deltaDUpper(s,c) < 0.0_pREAL .and. & dNeq0(dUpperOld(s,c) - prm%minDipoleHeight(s,c))) & deltaRhoDipole2SingleStress(s,8+c) = rhoDip(s,c) * deltaDUpper(s,c) & / (dUpperOld(s,c) - prm%minDipoleHeight(s,c)) - forall (t=1:4) deltaRhoDipole2SingleStress(:,t) = -0.5_pReal * deltaRhoDipole2SingleStress(:,(t-1)/2+9) + forall (t=1:4) deltaRhoDipole2SingleStress(:,t) = -0.5_pREAL * deltaRhoDipole2SingleStress(:,(t-1)/2+9) forall (s = 1:prm%sum_N_sl, c = 1:2) plasticState(ph)%state(iD(s,c,ph),en) = dUpper(s,c) - plasticState(ph)%deltaState(:,en) = 0.0_pReal + plasticState(ph)%deltaState(:,en) = 0.0_pREAL del%rho(:,en) = reshape(deltaRhoRemobilization + deltaRhoDipole2SingleStress, [10*prm%sum_N_sl]) end associate @@ -955,9 +955,9 @@ end subroutine plastic_nonlocal_deltaState module subroutine nonlocal_dotState(Mp,timestep, & ph,en) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< MandelStress - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & timestep !< substepped crystallite time increment integer, intent(in) :: & ph, & @@ -967,7 +967,7 @@ module subroutine nonlocal_dotState(Mp,timestep, & c, & !< character of dislocation t, & !< type of dislocation s !< index of my current slip system - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & rho, & rho0, & !< dislocation density at beginning of time step rhoDot, & !< density evolution @@ -975,27 +975,27 @@ module subroutine nonlocal_dotState(Mp,timestep, & rhoDotSingle2DipoleGlide, & !< density evolution by dipole formation (by glide) rhoDotAthermalAnnihilation, & !< density evolution by athermal annihilation rhoDotThermalAnnihilation !< density evolution by thermal annihilation - real(pReal), dimension(param(ph)%sum_N_sl,8) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,8) :: & rhoSgl, & !< current single dislocation densities (positive/negative screw and edge without dipoles) my_rhoSgl0 !< single dislocation densities of central ip (positive/negative screw and edge without dipoles) - real(pReal), dimension(param(ph)%sum_N_sl,4) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,4) :: & v, & !< current dislocation glide velocity v0, & dot_gamma !< shear rates - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau, & !< current resolved shear stress v_climb !< climb velocity of edge dipoles - real(pReal), dimension(param(ph)%sum_N_sl,2) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,2) :: & rhoDip, & !< current dipole dislocation densities (screw and edge dipoles) dLower, & !< minimum stable dipole distance for edges and screws dUpper !< current maximum stable dipole distance for edges and screws - real(pReal) :: & + real(pREAL) :: & D_SD, & mu, & nu, Temperature - if (timestep <= 0.0_pReal) then - plasticState(ph)%dotState = 0.0_pReal + if (timestep <= 0.0_pREAL) then + plasticState(ph)%dotState = 0.0_pREAL return end if @@ -1005,8 +1005,8 @@ module subroutine nonlocal_dotState(Mp,timestep, & nu = elastic_nu(ph,en,prm%isotropic_bound) Temperature = thermal_T(ph,en) - tau = 0.0_pReal - dot_gamma = 0.0_pReal + tau = 0.0_pREAL + dot_gamma = 0.0_pREAL rho = getRho(ph,en) rhoSgl = rho(:,sgl) @@ -1022,31 +1022,31 @@ module subroutine nonlocal_dotState(Mp,timestep, & ! limits for stable dipole height do s = 1,prm%sum_N_sl tau(s) = math_tensordot(Mp, prm%P_sl(1:3,1:3,s)) + dst%tau_back(s,en) - if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal + if (abs(tau(s)) < 1.0e-15_pREAL) tau(s) = 1.0e-15_pREAL end do dLower = prm%minDipoleHeight - dUpper(:,1) = mu * prm%b_sl/(8.0_pReal * PI * (1.0_pReal - nu) * abs(tau)) - dUpper(:,2) = mu * prm%b_sl/(4.0_pReal * PI * abs(tau)) + dUpper(:,1) = mu * prm%b_sl/(8.0_pREAL * PI * (1.0_pREAL - nu) * abs(tau)) + dUpper(:,2) = mu * prm%b_sl/(4.0_pREAL * PI * abs(tau)) where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) & - dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1)) + dUpper(:,1) = min(1.0_pREAL/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1)) where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) & - dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2)) + dUpper(:,2) = min(1.0_pREAL/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2)) dUpper = max(dUpper,dLower) ! dislocation multiplication - rhoDotMultiplication = 0.0_pReal + rhoDotMultiplication = 0.0_pREAL isBCC: if (phase_lattice(ph) == 'cI') then - forall (s = 1:prm%sum_N_sl, sum(abs(v(s,1:4))) > 0.0_pReal) + forall (s = 1:prm%sum_N_sl, sum(abs(v(s,1:4))) > 0.0_pREAL) rhoDotMultiplication(s,1:2) = sum(abs(dot_gamma(s,3:4))) / prm%b_sl(s) & ! assuming double-cross-slip of screws to be decisive for multiplication * sqrt(stt%rho_forest(s,en)) / prm%i_sl(s) ! & ! mean free path - ! * 2.0_pReal * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4))) ! ratio of screw to overall velocity determines edge generation + ! * 2.0_pREAL * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4))) ! ratio of screw to overall velocity determines edge generation rhoDotMultiplication(s,3:4) = sum(abs(dot_gamma(s,3:4))) /prm%b_sl(s) & ! assuming double-cross-slip of screws to be decisive for multiplication * sqrt(stt%rho_forest(s,en)) / prm%i_sl(s) ! & ! mean free path - ! * 2.0_pReal * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4))) ! ratio of edge to overall velocity determines screw generation + ! * 2.0_pREAL * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4))) ! ratio of edge to overall velocity determines screw generation endforall else isBCC @@ -1063,20 +1063,20 @@ module subroutine nonlocal_dotState(Mp,timestep, & ! formation by glide do c = 1,2 - rhoDotSingle2DipoleGlide(:,2*c-1) = -2.0_pReal * dUpper(:,c) / prm%b_sl & + rhoDotSingle2DipoleGlide(:,2*c-1) = -2.0_pREAL * dUpper(:,c) / prm%b_sl & * ( rhoSgl(:,2*c-1) * abs(dot_gamma(:,2*c)) & ! negative mobile --> positive mobile + rhoSgl(:,2*c) * abs(dot_gamma(:,2*c-1)) & ! positive mobile --> negative mobile + abs(rhoSgl(:,2*c+4)) * abs(dot_gamma(:,2*c-1))) ! positive mobile --> negative immobile - rhoDotSingle2DipoleGlide(:,2*c) = -2.0_pReal * dUpper(:,c) / prm%b_sl & + rhoDotSingle2DipoleGlide(:,2*c) = -2.0_pREAL * dUpper(:,c) / prm%b_sl & * ( rhoSgl(:,2*c-1) * abs(dot_gamma(:,2*c)) & ! negative mobile --> positive mobile + rhoSgl(:,2*c) * abs(dot_gamma(:,2*c-1)) & ! positive mobile --> negative mobile + abs(rhoSgl(:,2*c+3)) * abs(dot_gamma(:,2*c))) ! negative mobile --> positive immobile - rhoDotSingle2DipoleGlide(:,2*c+3) = -2.0_pReal * dUpper(:,c) / prm%b_sl & + rhoDotSingle2DipoleGlide(:,2*c+3) = -2.0_pREAL * dUpper(:,c) / prm%b_sl & * rhoSgl(:,2*c+3) * abs(dot_gamma(:,2*c)) ! negative mobile --> positive immobile - rhoDotSingle2DipoleGlide(:,2*c+4) = -2.0_pReal * dUpper(:,c) / prm%b_sl & + rhoDotSingle2DipoleGlide(:,2*c+4) = -2.0_pREAL * dUpper(:,c) / prm%b_sl & * rhoSgl(:,2*c+4) * abs(dot_gamma(:,2*c-1)) ! positive mobile --> negative immobile rhoDotSingle2DipoleGlide(:,c+8) = abs(rhoDotSingle2DipoleGlide(:,2*c+3)) & @@ -1087,27 +1087,27 @@ module subroutine nonlocal_dotState(Mp,timestep, & ! athermal annihilation - rhoDotAthermalAnnihilation = 0.0_pReal + rhoDotAthermalAnnihilation = 0.0_pREAL forall (c=1:2) & - rhoDotAthermalAnnihilation(:,c+8) = -2.0_pReal * dLower(:,c) / prm%b_sl & - * ( 2.0_pReal * (rhoSgl(:,2*c-1) * abs(dot_gamma(:,2*c)) + rhoSgl(:,2*c) * abs(dot_gamma(:,2*c-1))) & ! was single hitting single - + 2.0_pReal * (abs(rhoSgl(:,2*c+3)) * abs(dot_gamma(:,2*c)) + abs(rhoSgl(:,2*c+4)) * abs(dot_gamma(:,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single + rhoDotAthermalAnnihilation(:,c+8) = -2.0_pREAL * dLower(:,c) / prm%b_sl & + * ( 2.0_pREAL * (rhoSgl(:,2*c-1) * abs(dot_gamma(:,2*c)) + rhoSgl(:,2*c) * abs(dot_gamma(:,2*c-1))) & ! was single hitting single + + 2.0_pREAL * (abs(rhoSgl(:,2*c+3)) * abs(dot_gamma(:,2*c)) + abs(rhoSgl(:,2*c+4)) * abs(dot_gamma(:,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single + rhoDip(:,c) * (abs(dot_gamma(:,2*c-1)) + abs(dot_gamma(:,2*c)))) ! single knocks dipole constituent ! annihilated screw dipoles leave edge jogs behind on the colinear system if (phase_lattice(ph) == 'cF') & forall (s = 1:prm%sum_N_sl, prm%colinearSystem(s) > 0) & rhoDotAthermalAnnihilation(prm%colinearSystem(s),1:2) = - rhoDotAthermalAnnihilation(s,10) & - * 0.25_pReal * sqrt(stt%rho_forest(s,en)) * (dUpper(s,2) + dLower(s,2)) * prm%f_ed + * 0.25_pREAL * sqrt(stt%rho_forest(s,en)) * (dUpper(s,2) + dLower(s,2)) * prm%f_ed ! thermally activated annihilation of edge dipoles by climb - rhoDotThermalAnnihilation = 0.0_pReal + rhoDotThermalAnnihilation = 0.0_pREAL D_SD = prm%D_0 * exp(-prm%Q_cl / (K_B * Temperature)) ! eq. 3.53 v_climb = D_SD * mu * prm%V_at & - / (PI * (1.0_pReal-nu) * (dUpper(:,1) + dLower(:,1)) * K_B * Temperature) ! eq. 3.54 + / (PI * (1.0_pREAL-nu) * (dUpper(:,1) + dLower(:,1)) * K_B * Temperature) ! eq. 3.54 forall (s = 1:prm%sum_N_sl, dUpper(s,1) > dLower(s,1)) & - rhoDotThermalAnnihilation(s,9) = max(- 4.0_pReal * rhoDip(s,1) * v_climb(s) / (dUpper(s,1) - dLower(s,1)), & + rhoDotThermalAnnihilation(s,9) = max(- 4.0_pREAL * rhoDip(s,1) * v_climb(s) / (dUpper(s,1) - dLower(s,1)), & - rhoDip(s,1) / timestep - rhoDotAthermalAnnihilation(s,9) & - rhoDotSingle2DipoleGlide(s,9)) ! make sure that we do not annihilate more dipoles than we have @@ -1120,7 +1120,7 @@ module subroutine nonlocal_dotState(Mp,timestep, & if ( any(rho(:,mob) + rhoDot(:,1:4) * timestep < -prm%atol_rho) & .or. any(rho(:,dip) + rhoDot(:,9:10) * timestep < -prm%atol_rho)) then - plasticState(ph)%dotState = IEEE_value(1.0_pReal,IEEE_quiet_NaN) + plasticState(ph)%dotState = IEEE_value(1.0_pREAL,IEEE_quiet_NaN) else dot%rho(:,en) = pack(rhoDot,.true.) dot%gamma(:,en) = sum(dot_gamma,2) @@ -1139,7 +1139,7 @@ non_recursive function rhoDotFlux(timestep,ph,en) #else function rhoDotFlux(timestep,ph,en) #endif - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & timestep !< substepped crystallite time increment integer, intent(in) :: & ph, & @@ -1161,33 +1161,33 @@ function rhoDotFlux(timestep,ph,en) np,& !< neighbor phase shortcut topp, & !< type of dislocation with opposite sign to t s !< index of my current slip system - real(pReal), dimension(param(ph)%sum_N_sl,10) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: & rho, & rho0, & !< dislocation density at beginning of time step rhoDotFlux !< density evolution by flux - real(pReal), dimension(param(ph)%sum_N_sl,8) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,8) :: & rhoSgl, & !< current single dislocation densities (positive/negative screw and edge without dipoles) neighbor_rhoSgl0, & !< current single dislocation densities of neighboring ip (positive/negative screw and edge without dipoles) my_rhoSgl0 !< single dislocation densities of central ip (positive/negative screw and edge without dipoles) - real(pReal), dimension(param(ph)%sum_N_sl,4) :: & + real(pREAL), dimension(param(ph)%sum_N_sl,4) :: & v, & !< current dislocation glide velocity v0, & neighbor_v0, & !< dislocation glide velocity of enighboring ip dot_gamma !< shear rates - real(pReal), dimension(3,param(ph)%sum_N_sl,4) :: & + real(pREAL), dimension(3,param(ph)%sum_N_sl,4) :: & m !< direction of dislocation motion - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & my_F, & !< my total deformation gradient neighbor_F, & !< total deformation gradient of my neighbor my_Fe, & !< my elastic deformation gradient neighbor_Fe, & !< elastic deformation gradient of my neighbor Favg !< average total deformation gradient of en and my neighbor - real(pReal), dimension(3) :: & + real(pREAL), dimension(3) :: & normal_neighbor2me, & !< interface normal pointing from my neighbor to en in neighbor's lattice configuration normal_neighbor2me_defConf, & !< interface normal pointing from my neighbor to en in shared deformed configuration normal_me2neighbor, & !< interface normal pointing from en to my neighbor in my lattice configuration normal_me2neighbor_defConf !< interface normal pointing from en to my neighbor in shared deformed configuration - real(pReal) :: & + real(pREAL) :: & area, & !< area of the current interface transmissivity, & !< overall transmissivity of dislocation flux to neighboring material point lineLength !< dislocation line length leaving the current interface @@ -1198,7 +1198,7 @@ function rhoDotFlux(timestep,ph,en) stt => state(ph)) ns = prm%sum_N_sl - dot_gamma = 0.0_pReal + dot_gamma = 0.0_pREAL rho = getRho(ph,en) rhoSgl = rho(:,sgl) @@ -1212,14 +1212,14 @@ function rhoDotFlux(timestep,ph,en) !**************************************************************************** !*** calculate dislocation fluxes (only for nonlocal plasticity) - rhoDotFlux = 0.0_pReal + rhoDotFlux = 0.0_pREAL if (plasticState(ph)%nonlocal) then !*** check CFL (Courant-Friedrichs-Lewy) condition for flux - if (any( abs(dot_gamma) > 0.0_pReal & ! any active slip system ... + if (any( abs(dot_gamma) > 0.0_pREAL & ! any active slip system ... .and. prm%C_CFL * abs(v0) * timestep & > geom(ph)%V_0(en)/ maxval(geom(ph)%IParea(:,en)))) then ! ...with velocity above critical value (we use the reference volume and area for simplicity here) - rhoDotFlux = IEEE_value(1.0_pReal,IEEE_quiet_NaN) ! enforce cutback + rhoDotFlux = IEEE_value(1.0_pREAL,IEEE_quiet_NaN) ! enforce cutback return end if @@ -1251,12 +1251,12 @@ function rhoDotFlux(timestep,ph,en) if (neighbor_n > 0) then ! if neighbor exists, average deformation gradient neighbor_F = phase_mechanical_F(np)%data(1:3,1:3,no) neighbor_Fe = matmul(neighbor_F, math_inv33(phase_mechanical_Fp(np)%data(1:3,1:3,no))) - Favg = 0.5_pReal * (my_F + neighbor_F) + Favg = 0.5_pREAL * (my_F + neighbor_F) else ! if no neighbor, take my value as average Favg = my_F end if - neighbor_v0 = 0.0_pReal ! needed for check of sign change in flux density below + neighbor_v0 = 0.0_pREAL ! needed for check of sign change in flux density below !* FLUX FROM MY NEIGHBOR TO ME !* This is only considered, if I have a neighbor of nonlocal plasticity @@ -1268,16 +1268,16 @@ function rhoDotFlux(timestep,ph,en) !* compatibility if (neighbor_n > 0) then if (phase_plasticity(np) == PLASTIC_NONLOCAL_ID .and. & - any(dependentState(ph)%compatibility(:,:,:,n,en) > 0.0_pReal)) then + any(dependentState(ph)%compatibility(:,:,:,n,en) > 0.0_pREAL)) then forall (s = 1:ns, t = 1:4) neighbor_v0(s,t) = plasticState(np)%state0(iV (s,t,np),no) - neighbor_rhoSgl0(s,t) = max(plasticState(np)%state0(iRhoU(s,t,np),no),0.0_pReal) + neighbor_rhoSgl0(s,t) = max(plasticState(np)%state0(iRhoU(s,t,np),no),0.0_pREAL) endforall - where (neighbor_rhoSgl0 * IPvolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%rho_min & + where (neighbor_rhoSgl0 * IPvolume(neighbor_ip,neighbor_el) ** 0.667_pREAL < prm%rho_min & .or. neighbor_rhoSgl0 < prm%rho_significant) & - neighbor_rhoSgl0 = 0.0_pReal + neighbor_rhoSgl0 = 0.0_pREAL normal_neighbor2me_defConf = math_det33(Favg) * matmul(math_inv33(transpose(Favg)), & IPareaNormal(1:3,neighbor_n,neighbor_ip,neighbor_el)) ! normal of the interface in (average) deformed configuration (pointing neighbor => en) normal_neighbor2me = matmul(transpose(neighbor_Fe), normal_neighbor2me_defConf) & @@ -1288,14 +1288,14 @@ function rhoDotFlux(timestep,ph,en) do t = 1,4 c = (t + 1) / 2 topp = t + mod(t,2) - mod(t+1,2) - if (neighbor_v0(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal & ! flux from my neighbor to en == entering flux for en - .and. v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal ) then ! ... only if no sign change in flux density + if (neighbor_v0(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pREAL & ! flux from my neighbor to en == entering flux for en + .and. v0(s,t) * neighbor_v0(s,t) >= 0.0_pREAL ) then ! ... only if no sign change in flux density lineLength = neighbor_rhoSgl0(s,t) * neighbor_v0(s,t) & * math_inner(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface - where (dependentState(ph)%compatibility(c,:,s,n,en) > 0.0_pReal) & + where (dependentState(ph)%compatibility(c,:,s,n,en) > 0.0_pREAL) & rhoDotFlux(:,t) = rhoDotFlux(1:ns,t) & + lineLength/geom(ph)%V_0(en)*dependentState(ph)%compatibility(c,:,s,n,en)**2 ! transferring to equally signed mobile dislocation type - where (dependentState(ph)%compatibility(c,:,s,n,en) < 0.0_pReal) & + where (dependentState(ph)%compatibility(c,:,s,n,en) < 0.0_pREAL) & rhoDotFlux(:,topp) = rhoDotFlux(:,topp) & + lineLength/geom(ph)%V_0(en)*dependentState(ph)%compatibility(c,:,s,n,en)**2 ! transferring to opposite signed mobile dislocation type @@ -1324,18 +1324,18 @@ function rhoDotFlux(timestep,ph,en) do s = 1,ns do t = 1,4 c = (t + 1) / 2 - if (v0(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then ! flux from en to my neighbor == leaving flux for en (might also be a pure flux from my mobile density to dead density if interface not at all transmissive) - if (v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal) then ! no sign change in flux density + if (v0(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_pREAL ) then ! flux from en to my neighbor == leaving flux for en (might also be a pure flux from my mobile density to dead density if interface not at all transmissive) + if (v0(s,t) * neighbor_v0(s,t) >= 0.0_pREAL) then ! no sign change in flux density transmissivity = sum(dependentState(ph)%compatibility(c,:,s,n,en)**2) ! overall transmissivity from this slip system to my neighbor else ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor - transmissivity = 0.0_pReal + transmissivity = 0.0_pREAL end if lineLength = my_rhoSgl0(s,t) * v0(s,t) & * math_inner(m(1:3,s,t), normal_me2neighbor) * area ! positive line length of mobiles that wants to leave through this interface rhoDotFlux(s,t) = rhoDotFlux(s,t) - lineLength / geom(ph)%V_0(en) ! subtract dislocation flux from current type rhoDotFlux(s,t+4) = rhoDotFlux(s,t+4) & - + lineLength / geom(ph)%V_0(en) * (1.0_pReal - transmissivity) & - * sign(1.0_pReal, v0(s,t)) ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point + + lineLength / geom(ph)%V_0(en) * (1.0_pREAL - transmissivity) & + * sign(1.0_pREAL, v0(s,t)) ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point end if end do end do @@ -1374,9 +1374,9 @@ module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) ns, & ! number of active slip systems s1, & ! slip system index (en) s2 ! slip system index (my neighbor) - real(pReal), dimension(2,param(ph)%sum_N_sl,param(ph)%sum_N_sl,nIPneighbors) :: & + real(pREAL), dimension(2,param(ph)%sum_N_sl,param(ph)%sum_N_sl,nIPneighbors) :: & my_compatibility ! my_compatibility for current element and ip - real(pReal) :: & + real(pREAL) :: & my_compatibilitySum, & thresholdValue, & nThresholdValues @@ -1390,8 +1390,8 @@ module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) en = material_entry_phase(1,(el-1)*discretization_nIPs + ip) !*** start out fully compatible - my_compatibility = 0.0_pReal - forall(s1 = 1:ns) my_compatibility(:,s1,s1,:) = 1.0_pReal + my_compatibility = 0.0_pREAL + forall(s1 = 1:ns) my_compatibility(:,s1,s1,:) = 1.0_pREAL neighbors: do n = 1,nIPneighbors neighbor_e = IPneighborhood(1,n,ip,el) @@ -1405,8 +1405,8 @@ module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) elseif (neighbor_phase /= ph) then !* PHASE BOUNDARY if (plasticState(neighbor_phase)%nonlocal .and. plasticState(ph)%nonlocal) & - forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = 0.0_pReal - elseif (prm%chi_GB >= 0.0_pReal) then + forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = 0.0_pREAL + elseif (prm%chi_GB >= 0.0_pREAL) then !* GRAIN BOUNDARY if (any(dNeq(phase_O_0(ph)%data(en)%asQuaternion(), & phase_O_0(neighbor_phase)%data(neighbor_me)%asQuaternion())) .and. & @@ -1435,21 +1435,21 @@ module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) mis%rotate(prm%slip_direction(1:3,s2)))) end do neighborSlipSystems - my_compatibilitySum = 0.0_pReal + my_compatibilitySum = 0.0_pREAL belowThreshold = .true. - do while (my_compatibilitySum < 1.0_pReal .and. any(belowThreshold)) + do while (my_compatibilitySum < 1.0_pREAL .and. any(belowThreshold)) thresholdValue = maxval(my_compatibility(2,:,s1,n), belowThreshold) ! screws always positive - nThresholdValues = real(count(my_compatibility(2,:,s1,n) >= thresholdValue),pReal) + nThresholdValues = real(count(my_compatibility(2,:,s1,n) >= thresholdValue),pREAL) where (my_compatibility(2,:,s1,n) >= thresholdValue) belowThreshold = .false. - if (my_compatibilitySum + thresholdValue * nThresholdValues > 1.0_pReal) & + if (my_compatibilitySum + thresholdValue * nThresholdValues > 1.0_pREAL) & where (abs(my_compatibility(:,:,s1,n)) >= thresholdValue) & - my_compatibility(:,:,s1,n) = sign((1.0_pReal - my_compatibilitySum)/nThresholdValues,& + my_compatibility(:,:,s1,n) = sign((1.0_pREAL - my_compatibilitySum)/nThresholdValues,& my_compatibility(:,:,s1,n)) my_compatibilitySum = my_compatibilitySum + nThresholdValues * thresholdValue end do - where(belowThreshold) my_compatibility(1,:,s1,n) = 0.0_pReal - where(belowThreshold) my_compatibility(2,:,s1,n) = 0.0_pReal + where(belowThreshold) my_compatibility(1,:,s1,n) = 0.0_pREAL + where(belowThreshold) my_compatibility(2,:,s1,n) = 0.0_pREAL end do mySlipSystems end if @@ -1556,9 +1556,9 @@ subroutine stateInit(ini,phase,Nentries) from, & upto, & s - real(pReal), dimension(2) :: & + real(pREAL), dimension(2) :: & rnd - real(pReal) :: & + real(pREAL) :: & meanDensity, & totalVolume, & densityBinning, & @@ -1567,17 +1567,17 @@ subroutine stateInit(ini,phase,Nentries) associate(stt => state(phase)) - if (ini%random_rho_u > 0.0_pReal) then ! randomly distribute dislocation segments on random slip system and of random type in the volume + if (ini%random_rho_u > 0.0_pREAL) then ! randomly distribute dislocation segments on random slip system and of random type in the volume totalVolume = sum(geom(phase)%V_0) minimumIPVolume = minval(geom(phase)%V_0) - densityBinning = ini%random_rho_u_binning / minimumIpVolume ** (2.0_pReal / 3.0_pReal) + densityBinning = ini%random_rho_u_binning / minimumIpVolume ** (2.0_pREAL / 3.0_pREAL) ! fill random material points with dislocation segments until the desired overall density is reached - meanDensity = 0.0_pReal + meanDensity = 0.0_pREAL do while(meanDensity < ini%random_rho_u) call random_number(rnd) - e = nint(rnd(1)*real(Nentries,pReal) + 0.5_pReal) - s = nint(rnd(2)*real(sum(ini%N_sl),pReal)*4.0_pReal + 0.5_pReal) + e = nint(rnd(1)*real(Nentries,pREAL) + 0.5_pREAL) + s = nint(rnd(2)*real(sum(ini%N_sl),pREAL)*4.0_pREAL + 0.5_pREAL) meanDensity = meanDensity + densityBinning * geom(phase)%V_0(e) / totalVolume stt%rhoSglMobile(s,e) = densityBinning end do @@ -1607,20 +1607,20 @@ pure subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, T, integer, intent(in) :: & c, & !< dislocation character (1:edge, 2:screw) ph - real(pReal), intent(in) :: & + real(pREAL), intent(in) :: & T !< T - real(pReal), dimension(param(ph)%sum_N_sl), intent(in) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), intent(in) :: & tau, & !< resolved external shear stress (without non Schmid effects) tauNS, & !< resolved external shear stress (including non Schmid effects) tauThreshold !< threshold shear stress - real(pReal), dimension(param(ph)%sum_N_sl), intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_sl), intent(out) :: & v, & !< velocity dv_dtau, & !< velocity derivative with respect to resolved shear stress (without non Schmid contributions) dv_dtauNS !< velocity derivative with respect to resolved shear stress (including non Schmid contributions) integer :: & s !< index of my current slip system - real(pReal) :: & + real(pREAL) :: & tauRel_P, & tauRel_S, & tauEff, & !< effective shear stress @@ -1637,9 +1637,9 @@ pure subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, T, criticalStress_S !< maximum obstacle strength - v = 0.0_pReal - dv_dtau = 0.0_pReal - dv_dtauNS = 0.0_pReal + v = 0.0_pREAL + dv_dtau = 0.0_pREAL + dv_dtauNS = 0.0_pREAL associate(prm => param(ph)) @@ -1647,18 +1647,18 @@ pure subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, T, if (abs(tau(s)) > tauThreshold(s)) then !* Peierls contribution - tauEff = max(0.0_pReal, abs(tauNS(s)) - tauThreshold(s)) + tauEff = max(0.0_pREAL, abs(tauNS(s)) - tauThreshold(s)) lambda_P = prm%b_sl(s) activationVolume_P = prm%w *prm%b_sl(s)**3 criticalStress_P = prm%peierlsStress(s,c) activationEnergy_P = criticalStress_P * activationVolume_P - tauRel_P = min(1.0_pReal, tauEff / criticalStress_P) - tPeierls = 1.0_pReal / prm%nu_a & + tauRel_P = min(1.0_pREAL, tauEff / criticalStress_P) + tPeierls = 1.0_pREAL / prm%nu_a & * exp(activationEnergy_P / (K_B * T) & - * (1.0_pReal - tauRel_P**prm%p)**prm%q) + * (1.0_pREAL - tauRel_P**prm%p)**prm%q) dtPeierls_dtau = merge(tPeierls * prm%p * prm%q * activationVolume_P / (K_B * T) & - * (1.0_pReal - tauRel_P**prm%p)**(prm%q-1.0_pReal) * tauRel_P**(prm%p-1.0_pReal), & - 0.0_pReal, & + * (1.0_pREAL - tauRel_P**prm%p)**(prm%q-1.0_pREAL) * tauRel_P**(prm%p-1.0_pREAL), & + 0.0_pREAL, & tauEff < criticalStress_P) ! Contribution from solid solution strengthening @@ -1666,19 +1666,19 @@ pure subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, T, lambda_S = prm%b_sl(s) / sqrt(prm%c_sol) activationVolume_S = prm%f_sol * prm%b_sl(s)**3 / sqrt(prm%c_sol) criticalStress_S = prm%Q_sol / activationVolume_S - tauRel_S = min(1.0_pReal, tauEff / criticalStress_S) - tSolidSolution = 1.0_pReal / prm%nu_a & - * exp(prm%Q_sol / (K_B * T)* (1.0_pReal - tauRel_S**prm%p)**prm%q) + tauRel_S = min(1.0_pREAL, tauEff / criticalStress_S) + tSolidSolution = 1.0_pREAL / prm%nu_a & + * exp(prm%Q_sol / (K_B * T)* (1.0_pREAL - tauRel_S**prm%p)**prm%q) dtSolidSolution_dtau = merge(tSolidSolution * prm%p * prm%q * activationVolume_S / (K_B * T) & - * (1.0_pReal - tauRel_S**prm%p)**(prm%q-1.0_pReal)* tauRel_S**(prm%p-1.0_pReal), & - 0.0_pReal, & + * (1.0_pREAL - tauRel_S**prm%p)**(prm%q-1.0_pREAL)* tauRel_S**(prm%p-1.0_pREAL), & + 0.0_pREAL, & tauEff < criticalStress_S) !* viscous glide velocity tauEff = abs(tau(s)) - tauThreshold(s) - v(s) = sign(1.0_pReal,tau(s)) & + v(s) = sign(1.0_pREAL,tau(s)) & / (tPeierls / lambda_P + tSolidSolution / lambda_S + prm%B /(prm%b_sl(s) * tauEff)) dv_dtau(s) = v(s)**2 * (dtSolidSolution_dtau / lambda_S + prm%B / (prm%b_sl(s) * tauEff**2)) dv_dtauNS(s) = v(s)**2 * dtPeierls_dtau / lambda_P @@ -1698,7 +1698,7 @@ end subroutine kinetics pure function getRho(ph,en) result(rho) integer, intent(in) :: ph, en - real(pReal), dimension(param(ph)%sum_N_sl,10) :: rho + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: rho associate(prm => param(ph)) @@ -1706,11 +1706,11 @@ pure function getRho(ph,en) result(rho) rho = reshape(state(ph)%rho(:,en),[prm%sum_N_sl,10]) ! ensure positive densities (not for imm, they have a sign) - rho(:,mob) = max(rho(:,mob),0.0_pReal) - rho(:,dip) = max(rho(:,dip),0.0_pReal) + rho(:,mob) = max(rho(:,mob),0.0_pREAL) + rho(:,dip) = max(rho(:,dip),0.0_pREAL) - where(abs(rho) < max(prm%rho_min/geom(ph)%V_0(en)**(2.0_pReal/3.0_pReal),prm%rho_significant)) & - rho = 0.0_pReal + where(abs(rho) < max(prm%rho_min/geom(ph)%V_0(en)**(2.0_pREAL/3.0_pREAL),prm%rho_significant)) & + rho = 0.0_pREAL end associate @@ -1724,7 +1724,7 @@ end function getRho pure function getRho0(ph,en) result(rho0) integer, intent(in) :: ph, en - real(pReal), dimension(param(ph)%sum_N_sl,10) :: rho0 + real(pREAL), dimension(param(ph)%sum_N_sl,10) :: rho0 associate(prm => param(ph)) @@ -1732,11 +1732,11 @@ pure function getRho0(ph,en) result(rho0) rho0 = reshape(state0(ph)%rho(:,en),[prm%sum_N_sl,10]) ! ensure positive densities (not for imm, they have a sign) - rho0(:,mob) = max(rho0(:,mob),0.0_pReal) - rho0(:,dip) = max(rho0(:,dip),0.0_pReal) + rho0(:,mob) = max(rho0(:,mob),0.0_pREAL) + rho0(:,dip) = max(rho0(:,dip),0.0_pREAL) - where (abs(rho0) < max(prm%rho_min/geom(ph)%V_0(en)**(2.0_pReal/3.0_pReal),prm%rho_significant)) & - rho0 = 0.0_pReal + where (abs(rho0) < max(prm%rho_min/geom(ph)%V_0(en)**(2.0_pREAL/3.0_pREAL),prm%rho_significant)) & + rho0 = 0.0_pREAL end associate @@ -1748,10 +1748,10 @@ subroutine storeGeometry(ph) integer, intent(in) :: ph integer :: ce, co, nCell - real(pReal), dimension(:), allocatable :: V + real(pREAL), dimension(:), allocatable :: V integer, dimension(:,:,:), allocatable :: neighborhood - real(pReal), dimension(:,:), allocatable :: area, coords - real(pReal), dimension(:,:,:), allocatable :: areaNormal + real(pREAL), dimension(:,:), allocatable :: area, coords + real(pREAL), dimension(:,:,:), allocatable :: areaNormal nCell = product(shape(IPvolume)) diff --git a/src/phase_mechanical_plastic_phenopowerlaw.f90 b/src/phase_mechanical_plastic_phenopowerlaw.f90 index a32c0ea67..b83c7a2d4 100644 --- a/src/phase_mechanical_plastic_phenopowerlaw.f90 +++ b/src/phase_mechanical_plastic_phenopowerlaw.f90 @@ -7,30 +7,30 @@ submodule(phase:plastic) phenopowerlaw type :: tParameters - real(pReal) :: & - dot_gamma_0_sl = 1.0_pReal, & !< reference shear strain rate for slip - dot_gamma_0_tw = 1.0_pReal, & !< reference shear strain rate for twin - n_sl = 1.0_pReal, & !< stress exponent for slip - n_tw = 1.0_pReal, & !< stress exponent for twin - f_sat_sl_tw = 1.0_pReal, & !< push-up factor for slip saturation due to twinning - c_1 = 1.0_pReal, & - c_2 = 1.0_pReal, & - c_3 = 1.0_pReal, & - c_4 = 1.0_pReal, & - h_0_sl_sl = 1.0_pReal, & !< reference hardening slip - slip - h_0_tw_sl = 1.0_pReal, & !< reference hardening twin - slip - h_0_tw_tw = 1.0_pReal, & !< reference hardening twin - twin - a_sl = 1.0_pReal - real(pReal), allocatable, dimension(:) :: & + real(pREAL) :: & + dot_gamma_0_sl = 1.0_pREAL, & !< reference shear strain rate for slip + dot_gamma_0_tw = 1.0_pREAL, & !< reference shear strain rate for twin + n_sl = 1.0_pREAL, & !< stress exponent for slip + n_tw = 1.0_pREAL, & !< stress exponent for twin + f_sat_sl_tw = 1.0_pREAL, & !< push-up factor for slip saturation due to twinning + c_1 = 1.0_pREAL, & + c_2 = 1.0_pREAL, & + c_3 = 1.0_pREAL, & + c_4 = 1.0_pREAL, & + h_0_sl_sl = 1.0_pREAL, & !< reference hardening slip - slip + h_0_tw_sl = 1.0_pREAL, & !< reference hardening twin - slip + h_0_tw_tw = 1.0_pREAL, & !< reference hardening twin - twin + a_sl = 1.0_pREAL + real(pREAL), allocatable, dimension(:) :: & xi_inf_sl, & !< maximum critical shear stress for slip h_int, & !< per family hardening activity (optional) gamma_char !< characteristic shear for twins - real(pReal), allocatable, dimension(:,:) :: & + real(pREAL), allocatable, dimension(:,:) :: & h_sl_sl, & !< slip resistance from slip activity h_sl_tw, & !< slip resistance from twin activity h_tw_sl, & !< twin resistance from slip activity h_tw_tw !< twin resistance from twin activity - real(pReal), allocatable, dimension(:,:,:) :: & + real(pREAL), allocatable, dimension(:,:,:) :: & P_sl, & P_tw, & P_nS_pos, & @@ -56,7 +56,7 @@ submodule(phase:plastic) phenopowerlaw end type tIndexDotState type :: tPhenopowerlawState - real(pReal), pointer, dimension(:,:) :: & + real(pREAL), pointer, dimension(:,:) :: & xi_sl, & xi_tw, & gamma_sl, & @@ -87,7 +87,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) integer, dimension(:), allocatable :: & N_sl, & !< number of slip-systems for a given slip family N_tw !< number of twin-systems for a given twin family - real(pReal), dimension(:), allocatable :: & + real(pREAL), dimension(:), allocatable :: & xi_0_sl, & !< initial critical shear stress for slip xi_0_tw, & !< initial critical shear stress for twin a !< non-Schmid coefficients @@ -156,7 +156,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) xi_0_sl = pl%get_as1dReal('xi_0_sl', requiredSize=size(N_sl)) prm%xi_inf_sl = pl%get_as1dReal('xi_inf_sl', requiredSize=size(N_sl)) prm%h_int = pl%get_as1dReal('h_int', requiredSize=size(N_sl), & - defaultVal=[(0.0_pReal,i=1,size(N_sl))]) + defaultVal=[(0.0_pREAL,i=1,size(N_sl))]) prm%dot_gamma_0_sl = pl%get_asReal('dot_gamma_0_sl') prm%n_sl = pl%get_asReal('n_sl') @@ -169,11 +169,11 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) prm%h_int = math_expand(prm%h_int, N_sl) ! sanity checks - if ( prm%dot_gamma_0_sl <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0_sl' - if ( prm%a_sl <= 0.0_pReal) extmsg = trim(extmsg)//' a_sl' - if ( prm%n_sl <= 0.0_pReal) extmsg = trim(extmsg)//' n_sl' - if (any(xi_0_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_0_sl' - if (any(prm%xi_inf_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_inf_sl' + if ( prm%dot_gamma_0_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0_sl' + if ( prm%a_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' a_sl' + if ( prm%n_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' n_sl' + if (any(xi_0_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_0_sl' + if (any(prm%xi_inf_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_inf_sl' else slipActive xi_0_sl = emptyRealArray @@ -193,10 +193,10 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) xi_0_tw = pl%get_as1dReal('xi_0_tw',requiredSize=size(N_tw)) - prm%c_1 = pl%get_asReal('c_1',defaultVal=0.0_pReal) - prm%c_2 = pl%get_asReal('c_2',defaultVal=1.0_pReal) - prm%c_3 = pl%get_asReal('c_3',defaultVal=0.0_pReal) - prm%c_4 = pl%get_asReal('c_4',defaultVal=0.0_pReal) + prm%c_1 = pl%get_asReal('c_1',defaultVal=0.0_pREAL) + prm%c_2 = pl%get_asReal('c_2',defaultVal=1.0_pREAL) + prm%c_3 = pl%get_asReal('c_3',defaultVal=0.0_pREAL) + prm%c_4 = pl%get_asReal('c_4',defaultVal=0.0_pREAL) prm%dot_gamma_0_tw = pl%get_asReal('dot_gamma_0_tw') prm%n_tw = pl%get_asReal('n_tw') prm%f_sat_sl_tw = pl%get_asReal('f_sat_sl-tw') @@ -206,8 +206,8 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) xi_0_tw = math_expand(xi_0_tw,N_tw) ! sanity checks - if (prm%dot_gamma_0_tw <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0_tw' - if (prm%n_tw <= 0.0_pReal) extmsg = trim(extmsg)//' n_tw' + if (prm%dot_gamma_0_tw <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0_tw' + if (prm%n_tw <= 0.0_pREAL) extmsg = trim(extmsg)//' n_tw' else twinActive xi_0_tw = emptyRealArray @@ -226,7 +226,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) else slipAndTwinActive allocate(prm%h_sl_tw(prm%sum_N_sl,prm%sum_N_tw)) ! at least one dimension is 0 allocate(prm%h_tw_sl(prm%sum_N_tw,prm%sum_N_sl)) ! at least one dimension is 0 - prm%h_0_tw_sl = 0.0_pReal + prm%h_0_tw_sl = 0.0_pREAL end if slipAndTwinActive !-------------------------------------------------------------------------------------------------- @@ -246,28 +246,28 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) idx_dot%xi_sl = [startIndex,endIndex] stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl = spread(xi_0_sl, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw idx_dot%xi_tw = [startIndex,endIndex] stt%xi_tw => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_tw = spread(xi_0_tw, 2, Nmembers) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL) startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) - if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL) + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw idx_dot%gamma_tw = [startIndex,endIndex] stt%gamma_tw => plasticState(ph)%state(startIndex:endIndex,:) - plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) + plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL) end associate @@ -287,12 +287,12 @@ end function plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) - real(pReal), dimension(3,3), intent(out) :: & + real(pREAL), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & + real(pREAL), dimension(3,3,3,3), intent(out) :: & dLp_dMp !< derivative of Lp with respect to the Mandel stress - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & @@ -300,14 +300,14 @@ pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) integer :: & i,k,l,m,n - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_sl_pos,dot_gamma_sl_neg, & ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg - real(pReal), dimension(param(ph)%sum_N_tw) :: & + real(pREAL), dimension(param(ph)%sum_N_tw) :: & dot_gamma_tw,ddot_gamma_dtau_tw - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal + Lp = 0.0_pREAL + dLp_dMp = 0.0_pREAL associate(prm => param(ph)) @@ -338,18 +338,18 @@ end subroutine phenopowerlaw_LpAndItsTangent !-------------------------------------------------------------------------------------------------- module function phenopowerlaw_dotState(Mp,ph,en) result(dotState) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(plasticState(ph)%sizeDotState) :: & + real(pREAL), dimension(plasticState(ph)%sizeDotState) :: & dotState - real(pReal) :: & + real(pREAL) :: & xi_sl_sat_offset,& sumF - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & dot_gamma_sl_pos,dot_gamma_sl_neg, & left_SlipSlip @@ -365,10 +365,10 @@ module function phenopowerlaw_dotState(Mp,ph,en) result(dotState) sumF = sum(stt%gamma_tw(:,en)/prm%gamma_char) xi_sl_sat_offset = prm%f_sat_sl_tw*sqrt(sumF) - left_SlipSlip = sign(abs(1.0_pReal-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))**prm%a_sl, & - 1.0_pReal-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset)) + left_SlipSlip = sign(abs(1.0_pREAL-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))**prm%a_sl, & + 1.0_pREAL-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset)) - dot_xi_sl = prm%h_0_sl_sl * (1.0_pReal + prm%c_1 * sumF**prm%c_2) * (1.0_pReal + prm%h_int) & + dot_xi_sl = prm%h_0_sl_sl * (1.0_pREAL + prm%c_1 * sumF**prm%c_2) * (1.0_pREAL + prm%h_int) & * left_SlipSlip * matmul(prm%h_sl_sl,dot_gamma_sl) & + matmul(prm%h_sl_tw,dot_gamma_tw) @@ -431,20 +431,20 @@ end subroutine plastic_phenopowerlaw_result pure subroutine kinetics_sl(Mp,ph,en, & dot_gamma_sl_pos,dot_gamma_sl_neg,ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: & dot_gamma_sl_pos, & dot_gamma_sl_neg - real(pReal), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & + real(pREAL), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & ddot_gamma_dtau_sl_pos, & ddot_gamma_dtau_sl_neg - real(pReal), dimension(param(ph)%sum_N_sl) :: & + real(pREAL), dimension(param(ph)%sum_N_sl) :: & tau_sl_pos, & tau_sl_neg integer :: i @@ -454,35 +454,35 @@ pure subroutine kinetics_sl(Mp,ph,en, & do i = 1, prm%sum_N_sl tau_sl_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i)) tau_sl_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)), & - 0.0_pReal, prm%nonSchmidActive) + 0.0_pREAL, prm%nonSchmidActive) end do where(dNeq0(tau_sl_pos)) - dot_gamma_sl_pos = prm%dot_gamma_0_sl * merge(0.5_pReal,1.0_pReal, prm%nonSchmidActive) & ! 1/2 if non-Schmid active + dot_gamma_sl_pos = prm%dot_gamma_0_sl * merge(0.5_pREAL,1.0_pREAL, prm%nonSchmidActive) & ! 1/2 if non-Schmid active * sign(abs(tau_sl_pos/stt%xi_sl(:,en))**prm%n_sl, tau_sl_pos) else where - dot_gamma_sl_pos = 0.0_pReal + dot_gamma_sl_pos = 0.0_pREAL end where where(dNeq0(tau_sl_neg)) - dot_gamma_sl_neg = prm%dot_gamma_0_sl * 0.5_pReal & ! only used if non-Schmid active, always 1/2 + dot_gamma_sl_neg = prm%dot_gamma_0_sl * 0.5_pREAL & ! only used if non-Schmid active, always 1/2 * sign(abs(tau_sl_neg/stt%xi_sl(:,en))**prm%n_sl, tau_sl_neg) else where - dot_gamma_sl_neg = 0.0_pReal + dot_gamma_sl_neg = 0.0_pREAL end where if (present(ddot_gamma_dtau_sl_pos)) then where(dNeq0(dot_gamma_sl_pos)) ddot_gamma_dtau_sl_pos = dot_gamma_sl_pos*prm%n_sl/tau_sl_pos else where - ddot_gamma_dtau_sl_pos = 0.0_pReal + ddot_gamma_dtau_sl_pos = 0.0_pREAL end where end if if (present(ddot_gamma_dtau_sl_neg)) then where(dNeq0(dot_gamma_sl_neg)) ddot_gamma_dtau_sl_neg = dot_gamma_sl_neg*prm%n_sl/tau_sl_neg else where - ddot_gamma_dtau_sl_neg = 0.0_pReal + ddot_gamma_dtau_sl_neg = 0.0_pREAL end where end if @@ -501,18 +501,18 @@ end subroutine kinetics_sl pure subroutine kinetics_tw(Mp,ph,en,& dot_gamma_tw,ddot_gamma_dtau_tw) - real(pReal), dimension(3,3), intent(in) :: & + real(pREAL), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & ph, & en - real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: & + real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: & dot_gamma_tw - real(pReal), dimension(param(ph)%sum_N_tw), intent(out), optional :: & + real(pREAL), dimension(param(ph)%sum_N_tw), intent(out), optional :: & ddot_gamma_dtau_tw - real(pReal), dimension(param(ph)%sum_N_tw) :: & + real(pREAL), dimension(param(ph)%sum_N_tw) :: & tau_tw integer :: i @@ -521,18 +521,18 @@ pure subroutine kinetics_tw(Mp,ph,en,& tau_tw = [(math_tensordot(Mp,prm%P_tw(1:3,1:3,i)),i=1,prm%sum_N_tw)] - where(tau_tw > 0.0_pReal) - dot_gamma_tw = (1.0_pReal-sum(stt%gamma_tw(:,en)/prm%gamma_char)) & ! only twin in untwinned volume fraction + where(tau_tw > 0.0_pREAL) + dot_gamma_tw = (1.0_pREAL-sum(stt%gamma_tw(:,en)/prm%gamma_char)) & ! only twin in untwinned volume fraction * prm%dot_gamma_0_tw*(abs(tau_tw)/stt%xi_tw(:,en))**prm%n_tw else where - dot_gamma_tw = 0.0_pReal + dot_gamma_tw = 0.0_pREAL end where if (present(ddot_gamma_dtau_tw)) then where(dNeq0(dot_gamma_tw)) ddot_gamma_dtau_tw = dot_gamma_tw*prm%n_tw/tau_tw else where - ddot_gamma_dtau_tw = 0.0_pReal + ddot_gamma_dtau_tw = 0.0_pREAL end where end if diff --git a/src/phase_thermal.f90 b/src/phase_thermal.f90 index 325076c08..449e08ab8 100644 --- a/src/phase_thermal.f90 +++ b/src/phase_thermal.f90 @@ -4,8 +4,8 @@ submodule(phase) thermal type :: tThermalParameters - real(pReal) :: C_p = 0.0_pReal !< heat capacity - real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity + real(pREAL) :: C_p = 0.0_pREAL !< heat capacity + real(pREAL), dimension(3,3) :: K = 0.0_pREAL !< thermal conductivity character(len=pSTRLEN), allocatable, dimension(:) :: output end type tThermalParameters @@ -22,7 +22,7 @@ submodule(phase) thermal end enum type :: tDataContainer ! ?? not very telling name. Better: "fieldQuantities" ?? - real(pReal), dimension(:), allocatable :: T, dot_T + real(pREAL), dimension(:), allocatable :: T, dot_T end type tDataContainer integer(kind(THERMAL_UNDEFINED_ID)), dimension(:,:), allocatable :: & thermal_source @@ -57,14 +57,14 @@ submodule(phase) thermal integer, intent(in) :: & ph, & en - real(pReal) :: f_T + real(pREAL) :: f_T end function dissipation_f_T module function externalheat_f_T(ph,en) result(f_T) integer, intent(in) :: & ph, & en - real(pReal) :: f_T + real(pREAL) :: f_T end function externalheat_f_T end interface @@ -100,7 +100,7 @@ module subroutine thermal_init(phases) do ph = 1, phases%length Nmembers = count(material_ID_phase == ph) allocate(current(ph)%T(Nmembers),source=T_ROOM) - allocate(current(ph)%dot_T(Nmembers),source=0.0_pReal) + allocate(current(ph)%dot_T(Nmembers),source=0.0_pREAL) phase => phases%get_dict(ph) thermal => phase%get_dict('thermal',defaultVal=emptyDict) @@ -156,13 +156,13 @@ end subroutine thermal_init module function phase_f_T(ph,en) result(f) integer, intent(in) :: ph, en - real(pReal) :: f + real(pREAL) :: f integer :: so - f = 0.0_pReal + f = 0.0_pREAL do so = 1, thermal_Nsources(ph) select case(thermal_source(so,ph)) @@ -211,7 +211,7 @@ end function phase_thermal_collectDotState module function phase_mu_T(co,ce) result(mu) integer, intent(in) :: co, ce - real(pReal) :: mu + real(pREAL) :: mu mu = phase_rho(material_ID_phase(co,ce)) & @@ -226,7 +226,7 @@ end function phase_mu_T module function phase_K_T(co,ce) result(K) integer, intent(in) :: co, ce - real(pReal), dimension(3,3) :: K + real(pREAL), dimension(3,3) :: K K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%K) @@ -236,7 +236,7 @@ end function phase_K_T module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en logical :: converged_ @@ -251,7 +251,7 @@ end function phase_thermal_constitutive !-------------------------------------------------------------------------------------------------- function integrateThermalState(Delta_t, ph,en) result(broken) - real(pReal), intent(in) :: Delta_t + real(pREAL), intent(in) :: Delta_t integer, intent(in) :: ph, en logical :: & broken @@ -323,7 +323,7 @@ end subroutine thermal_forward pure module function thermal_T(ph,en) result(T) integer, intent(in) :: ph, en - real(pReal) :: T + real(pREAL) :: T T = current(ph)%T(en) @@ -337,7 +337,7 @@ end function thermal_T module function thermal_dot_T(ph,en) result(dot_T) integer, intent(in) :: ph, en - real(pReal) :: dot_T + real(pREAL) :: dot_T dot_T = current(ph)%dot_T(en) @@ -350,7 +350,7 @@ end function thermal_dot_T !---------------------------------------------------------------------------------------------- module subroutine phase_thermal_setField(T,dot_T, co,ce) - real(pReal), intent(in) :: T, dot_T + real(pREAL), intent(in) :: T, dot_T integer, intent(in) :: ce, co diff --git a/src/phase_thermal_dissipation.f90 b/src/phase_thermal_dissipation.f90 index 74d7cd46f..573921670 100644 --- a/src/phase_thermal_dissipation.f90 +++ b/src/phase_thermal_dissipation.f90 @@ -8,7 +8,7 @@ submodule(phase:thermal) dissipation type :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & + real(pREAL) :: & kappa !< TAYLOR-QUINNEY factor end type tParameters @@ -80,9 +80,9 @@ end function dissipation_init module function dissipation_f_T(ph,en) result(f_T) integer, intent(in) :: ph, en - real(pReal) :: & + real(pREAL) :: & f_T - real(pReal), dimension(3,3) :: & + real(pREAL), dimension(3,3) :: & Mp !< Mandel stress work conjugate with Lp Mp = matmul(matmul(transpose(mechanical_F_i(ph,en)),mechanical_F_i(ph,en)),mechanical_S(ph,en)) diff --git a/src/phase_thermal_externalheat.f90 b/src/phase_thermal_externalheat.f90 index 304171c10..cdd037592 100644 --- a/src/phase_thermal_externalheat.f90 +++ b/src/phase_thermal_externalheat.f90 @@ -92,7 +92,7 @@ module subroutine externalheat_dotState(ph, en) so = source_thermal_externalheat_offset(ph) - thermalState(ph)%p(so)%dotState(1,en) = 1.0_pReal ! state is current time + thermalState(ph)%p(so)%dotState(1,en) = 1.0_pREAL ! state is current time end subroutine externalheat_dotState @@ -105,7 +105,7 @@ module function externalheat_f_T(ph,en) result(f_T) integer, intent(in) :: & ph, & en - real(pReal) :: & + real(pREAL) :: & f_T integer :: & diff --git a/src/polynomials.f90 b/src/polynomials.f90 index 103a9b695..062f99911 100644 --- a/src/polynomials.f90 +++ b/src/polynomials.f90 @@ -12,8 +12,8 @@ module polynomials private type, public :: tPolynomial - real(pReal), dimension(:), allocatable :: coef - real(pReal) :: x_ref = huge(0.0_pReal) + real(pREAL), dimension(:), allocatable :: coef + real(pREAL) :: x_ref = huge(0.0_pREAL) contains procedure, public :: at => eval end type tPolynomial @@ -47,8 +47,8 @@ end subroutine polynomials_init !-------------------------------------------------------------------------------------------------- pure function polynomial_from_coef(coef,x_ref) result(p) - real(pReal), dimension(0:), intent(in) :: coef - real(pReal), intent(in) :: x_ref + real(pREAL), dimension(0:), intent(in) :: coef + real(pREAL), intent(in) :: x_ref type(tPolynomial) :: p @@ -67,8 +67,8 @@ function polynomial_from_dict(dict,y,x) result(p) character(len=*), intent(in) :: y, x type(tPolynomial) :: p - real(pReal), dimension(:), allocatable :: coef - real(pReal) :: x_ref + real(pREAL), dimension(:), allocatable :: coef + real(pREAL) :: x_ref integer :: i, o character(len=1) :: o_s @@ -83,7 +83,7 @@ function polynomial_from_dict(dict,y,x) result(p) write(o_s,'(I0.0)') o if (dict%contains(y//','//x//'^'//o_s)) then x_ref = dict%get_asReal(x//'_ref') - coef = [coef,[(0.0_pReal,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)] + coef = [coef,[(0.0_pREAL,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)] end if end do @@ -99,8 +99,8 @@ end function polynomial_from_dict pure function eval(self,x) result(y) class(tPolynomial), intent(in) :: self - real(pReal), intent(in) :: x - real(pReal) :: y + real(pREAL), intent(in) :: x + real(pREAL) :: y integer :: o @@ -123,9 +123,9 @@ end function eval subroutine selfTest() type(tPolynomial) :: p1, p2 - real(pReal), dimension(5) :: coef + real(pREAL), dimension(5) :: coef integer :: i - real(pReal) :: x_ref, x, y + real(pREAL) :: x_ref, x, y type(tDict), pointer :: dict character(len=pSTRLEN), dimension(size(coef)) :: coef_s character(len=pSTRLEN) :: x_ref_s, x_s, YAML_s @@ -135,9 +135,9 @@ subroutine selfTest() call random_number(x_ref) call random_number(x) - coef = coef*10_pReal -0.5_pReal - x_ref = x_ref*10_pReal -0.5_pReal - x = x*10_pReal -0.5_pReal + coef = coef*10_pREAL -0.5_pREAL + x_ref = x_ref*10_pREAL -0.5_pREAL + x = x*10_pREAL -0.5_pREAL p1 = polynomial([coef(1)],x_ref) if (dNeq(p1%at(x),coef(1))) error stop 'polynomial: eval(constant)' @@ -158,37 +158,37 @@ subroutine selfTest() 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL dict => YAML_parse_str_asDict(trim(YAML_s)) p2 = polynomial(dict,'C','T') - if (dNeq(p1%at(x),p2%at(x),1.0e-6_pReal)) error stop 'polynomials: init' + if (dNeq(p1%at(x),p2%at(x),1.0e-6_pREAL)) error stop 'polynomials: init' y = coef(1)+coef(2)*(x-x_ref)+coef(3)*(x-x_ref)**2+coef(4)*(x-x_ref)**3+coef(5)*(x-x_ref)**4 - if (dNeq(p1%at(x),y,1.0e-6_pReal)) error stop 'polynomials: eval(full)' + if (dNeq(p1%at(x),y,1.0e-6_pREAL)) error stop 'polynomials: eval(full)' YAML_s = 'C: 0.0'//IO_EOL//& 'C,T: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL dict => YAML_parse_str_asDict(trim(YAML_s)) p1 = polynomial(dict,'C','T') - if (dNeq(p1%at(x_ref+x),-p1%at(x_ref-x),1.0e-10_pReal)) error stop 'polynomials: eval(linear)' + if (dNeq(p1%at(x_ref+x),-p1%at(x_ref-x),1.0e-10_pREAL)) error stop 'polynomials: eval(linear)' YAML_s = 'C: 0.0'//IO_EOL//& 'C,T^2: '//trim(adjustl(coef_s(3)))//IO_EOL//& 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL dict => YAML_parse_str_asDict(trim(YAML_s)) p1 = polynomial(dict,'C','T') - if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1e-10_pReal)) error stop 'polynomials: eval(quadratic)' + if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1e-10_pREAL)) error stop 'polynomials: eval(quadratic)' YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//& 'Y,X^3: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL dict => YAML_parse_str_asDict(trim(YAML_s)) p1 = polynomial(dict,'Y','X') - if (dNeq(p1%at(x_ref+x)-coef(1),-(p1%at(x_ref-x)-coef(1)),1.0e-8_pReal)) error stop 'polynomials: eval(cubic)' + if (dNeq(p1%at(x_ref+x)-coef(1),-(p1%at(x_ref-x)-coef(1)),1.0e-8_pREAL)) error stop 'polynomials: eval(cubic)' YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//& 'Y,X^4: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL dict => YAML_parse_str_asDict(trim(YAML_s)) p1 = polynomial(dict,'Y','X') - if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1.0e-6_pReal)) error stop 'polynomials: eval(quartic)' + if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1.0e-6_pREAL)) error stop 'polynomials: eval(quartic)' end subroutine selfTest diff --git a/src/prec.f90 b/src/prec.f90 index 6aa08567c..4f475a5aa 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -19,26 +19,26 @@ module prec public ! https://stevelionel.com/drfortran/2017/03/27/doctor-fortran-in-it-takes-all-kinds - integer, parameter :: pReal = IEEE_selected_real_kind(15,307) !< number with 15 significant digits, up to 1e+-307 (typically 64 bit) + integer, parameter :: pREAL = IEEE_selected_real_kind(15,307) !< number with 15 significant digits, up to 1e+-307 (typically 64 bit) integer, parameter :: pI32 = selected_int_kind(9) !< number with at least up to +-1e9 (typically 32 bit) integer, parameter :: pI64 = selected_int_kind(18) !< number with at least up to +-1e18 (typically 64 bit) #ifdef PETSC PetscInt, private :: dummy_int integer, parameter :: pPETSCINT = kind(dummy_int) PetscScalar, private :: dummy_scalar - real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar) + real(pREAL), parameter, private :: pPETSCSCALAR = kind(dummy_scalar) #endif integer, parameter :: pSTRLEN = 256 !< default string length integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux - real(pReal), parameter :: tol_math_check = 1.0e-8_pReal !< tolerance for internal math self-checks (rotation) + real(pREAL), parameter :: tol_math_check = 1.0e-8_pREAL !< tolerance for internal math self-checks (rotation) - real(pReal), private, parameter :: PREAL_EPSILON = epsilon(0.0_pReal) !< minimum positive number such that 1.0 + EPSILON /= 1.0. - real(pReal), private, parameter :: PREAL_MIN = tiny(0.0_pReal) !< smallest normalized floating point number + real(pREAL), private, parameter :: PREAL_EPSILON = epsilon(0.0_pREAL) !< minimum positive number such that 1.0 + EPSILON /= 1.0. + real(pREAL), private, parameter :: PREAL_MIN = tiny(0.0_pREAL) !< smallest normalized floating point number integer, dimension(0), parameter :: emptyIntArray = [integer::] - real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] + real(pREAL), dimension(0), parameter :: emptyRealArray = [real(pREAL)::] character(len=pSTRLEN), dimension(0), parameter :: emptyStrArray = [character(len=pSTRLEN)::] @@ -54,11 +54,11 @@ subroutine prec_init() print'(/,a,i3)', ' integer size / bit: ',bit_size(0) print'( a,i19)', ' maximum value: ',huge(0) - print'(/,a,i3)', ' real size / bit: ',storage_size(0.0_pReal) - print'( a,e10.3)', ' maximum value: ',huge(0.0_pReal) + print'(/,a,i3)', ' real size / bit: ',storage_size(0.0_pREAL) + print'( a,e10.3)', ' maximum value: ',huge(0.0_pREAL) print'( a,e10.3)', ' minimum value: ',PREAL_MIN print'( a,e10.3)', ' epsilon value: ',PREAL_EPSILON - print'( a,i3)', ' decimal precision: ',precision(0.0_pReal) + print'( a,i3)', ' decimal precision: ',precision(0.0_pREAL) call prec_selfTest() @@ -74,8 +74,8 @@ end subroutine prec_init !-------------------------------------------------------------------------------------------------- logical elemental pure function dEq(a,b,tol) - real(pReal), intent(in) :: a,b - real(pReal), intent(in), optional :: tol + real(pREAL), intent(in) :: a,b + real(pREAL), intent(in), optional :: tol if (present(tol)) then @@ -95,8 +95,8 @@ end function dEq !-------------------------------------------------------------------------------------------------- logical elemental pure function dNeq(a,b,tol) - real(pReal), intent(in) :: a,b - real(pReal), intent(in), optional :: tol + real(pREAL), intent(in) :: a,b + real(pREAL), intent(in), optional :: tol dNeq = .not. dEq(a,b,tol) @@ -112,14 +112,14 @@ end function dNeq !-------------------------------------------------------------------------------------------------- logical elemental pure function dEq0(a,tol) - real(pReal), intent(in) :: a - real(pReal), intent(in), optional :: tol + real(pREAL), intent(in) :: a + real(pREAL), intent(in), optional :: tol if (present(tol)) then dEq0 = abs(a) <= tol else - dEq0 = abs(a) <= PREAL_MIN * 10.0_pReal + dEq0 = abs(a) <= PREAL_MIN * 10.0_pREAL end if end function dEq0 @@ -133,8 +133,8 @@ end function dEq0 !-------------------------------------------------------------------------------------------------- logical elemental pure function dNeq0(a,tol) - real(pReal), intent(in) :: a - real(pReal), intent(in), optional :: tol + real(pREAL), intent(in) :: a + real(pREAL), intent(in), optional :: tol dNeq0 = .not. dEq0(a,tol) @@ -151,8 +151,8 @@ end function dNeq0 !-------------------------------------------------------------------------------------------------- logical elemental pure function cEq(a,b,tol) - complex(pReal), intent(in) :: a,b - real(pReal), intent(in), optional :: tol + complex(pREAL), intent(in) :: a,b + real(pREAL), intent(in), optional :: tol if (present(tol)) then @@ -173,8 +173,8 @@ end function cEq !-------------------------------------------------------------------------------------------------- logical elemental pure function cNeq(a,b,tol) - complex(pReal), intent(in) :: a,b - real(pReal), intent(in), optional :: tol + complex(pREAL), intent(in) :: a,b + real(pREAL), intent(in), optional :: tol cNeq = .not. cEq(a,b,tol) @@ -248,13 +248,13 @@ end function prec_bytesToC_INT64_T subroutine prec_selfTest() integer, allocatable, dimension(:) :: realloc_lhs_test - real(pReal), dimension(1) :: f + real(pREAL), dimension(1) :: f integer(pI64), dimension(1) :: i - real(pReal), dimension(2) :: r + real(pREAL), dimension(2) :: r #ifdef PETSC - if (pReal /= pPETSCSCALAR) error stop 'PETSc and DAMASK scalar datatypes do not match' + if (pREAL /= pPETSCSCALAR) error stop 'PETSc and DAMASK scalar datatypes do not match' #endif realloc_lhs_test = [1,2] if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation' @@ -267,11 +267,11 @@ subroutine prec_selfTest() ! https://www.binaryconvert.com ! https://www.rapidtables.com/convert/number/binary-to-decimal.html - f = real(prec_bytesToC_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pReal) - if (dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'prec_bytesToC_FLOAT' + f = real(prec_bytesToC_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pREAL) + if (dNeq(f(1),20191102.0_pREAL,0.0_pREAL)) error stop 'prec_bytesToC_FLOAT' - f = real(prec_bytesToC_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pReal) - if (dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'prec_bytesToC_DOUBLE' + f = real(prec_bytesToC_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pREAL) + if (dNeq(f(1),20191102.0_pREAL,0.0_pREAL)) error stop 'prec_bytesToC_DOUBLE' i = int(prec_bytesToC_INT32_T(int([+126,+23,+52,+1],C_SIGNED_CHAR)),pI64) if (i(1) /= 20191102_pI64) error stop 'prec_bytesToC_INT32_T' diff --git a/src/result.f90 b/src/result.f90 index da538f734..b21429fa8 100644 --- a/src/result.f90 +++ b/src/result.f90 @@ -141,7 +141,7 @@ end subroutine result_closeJobFile subroutine result_addIncrement(inc,time) integer, intent(in) :: inc - real(pReal), intent(in) :: time + real(pREAL), intent(in) :: time character(len=pSTRLEN) :: incChar @@ -251,7 +251,7 @@ end subroutine result_addAttribute_int subroutine result_addAttribute_real(attrLabel,attrValue,path) character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue + real(pREAL), intent(in) :: attrValue character(len=*), intent(in), optional :: path @@ -296,7 +296,7 @@ end subroutine result_addAttribute_int_array subroutine result_addAttribute_real_array(attrLabel,attrValue,path) character(len=*), intent(in) :: attrLabel - real(pReal), intent(in), dimension(:) :: attrValue + real(pREAL), intent(in), dimension(:) :: attrValue character(len=*), intent(in), optional :: path @@ -345,7 +345,7 @@ subroutine result_writeScalarDataset_real(dataset,group,label,description,SIunit character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit - real(pReal), intent(in), dimension(:) :: dataset + real(pREAL), intent(in), dimension(:) :: dataset integer(HID_T) :: groupHandle @@ -366,7 +366,7 @@ subroutine result_writeVectorDataset_real(dataset,group,label,description,SIunit character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit character(len=*), intent(in), dimension(:), optional :: systems - real(pReal), intent(in), dimension(:,:) :: dataset + real(pREAL), intent(in), dimension(:,:) :: dataset integer(HID_T) :: groupHandle @@ -390,11 +390,11 @@ subroutine result_writeTensorDataset_real(dataset,group,label,description,SIunit character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit logical, intent(in), optional :: transposed - real(pReal), intent(in), dimension(:,:,:) :: dataset + real(pREAL), intent(in), dimension(:,:,:) :: dataset integer :: i integer(HID_T) :: groupHandle - real(pReal), dimension(:,:,:), allocatable :: dataset_transposed + real(pREAL), dimension(:,:,:), allocatable :: dataset_transposed groupHandle = result_openGroup(group) diff --git a/src/rotations.f90 b/src/rotations.f90 index 35fb30026..58aa87ee0 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -53,10 +53,10 @@ module rotations implicit none(type,external) private - real(pReal), parameter :: P = -1.0_pReal !< parameter for orientation conversion. + real(pREAL), parameter :: P = -1.0_pREAL !< parameter for orientation conversion. type, public :: tRotation - real(pReal), dimension(4) :: q + real(pREAL), dimension(4) :: q contains procedure, public :: asQuaternion procedure, public :: asEulers @@ -79,16 +79,16 @@ module rotations procedure, public :: standardize end type tRotation - real(pReal), parameter :: & - PREF = sqrt(6.0_pReal/PI), & - A = PI**(5.0_pReal/6.0_pReal)/6.0_pReal**(1.0_pReal/6.0_pReal), & - AP = PI**(2.0_pReal/3.0_pReal), & + real(pREAL), parameter :: & + PREF = sqrt(6.0_pREAL/PI), & + A = PI**(5.0_pREAL/6.0_pREAL)/6.0_pREAL**(1.0_pREAL/6.0_pREAL), & + AP = PI**(2.0_pREAL/3.0_pREAL), & SC = A/AP, & - BETA = A/2.0_pReal, & - R1 = (3.0_pReal*PI/4.0_pReal)**(1.0_pReal/3.0_pReal), & - R2 = sqrt(2.0_pReal), & - PI12 = PI/12.0_pReal, & - PREK = R1 * 2.0_pReal**(1.0_pReal/4.0_pReal)/BETA + BETA = A/2.0_pREAL, & + R1 = (3.0_pREAL*PI/4.0_pREAL)**(1.0_pREAL/3.0_pREAL), & + R2 = sqrt(2.0_pREAL), & + PI12 = PI/12.0_pREAL, & + PREK = R1 * 2.0_pREAL**(1.0_pREAL/4.0_pREAL)/BETA public :: & rotations_init, & @@ -117,7 +117,7 @@ end subroutine rotations_init pure function asQuaternion(self) class(tRotation), intent(in) :: self - real(pReal), dimension(4) :: asQuaternion + real(pREAL), dimension(4) :: asQuaternion asQuaternion = self%q @@ -127,7 +127,7 @@ end function asQuaternion pure function asEulers(self) class(tRotation), intent(in) :: self - real(pReal), dimension(3) :: asEulers + real(pREAL), dimension(3) :: asEulers asEulers = qu2eu(self%q) @@ -137,7 +137,7 @@ end function asEulers pure function asAxisAngle(self) class(tRotation), intent(in) :: self - real(pReal), dimension(4) :: asAxisAngle + real(pREAL), dimension(4) :: asAxisAngle asAxisAngle = qu2ax(self%q) @@ -147,7 +147,7 @@ end function asAxisAngle pure function asMatrix(self) class(tRotation), intent(in) :: self - real(pReal), dimension(3,3) :: asMatrix + real(pREAL), dimension(3,3) :: asMatrix asMatrix = qu2om(self%q) @@ -160,10 +160,10 @@ end function asMatrix subroutine fromQuaternion(self,qu) class(tRotation), intent(out) :: self - real(pReal), dimension(4), intent(in) :: qu + real(pREAL), dimension(4), intent(in) :: qu - if (dNeq(norm2(qu),1.0_pReal,1.0e-8_pReal)) call IO_error(402,ext_msg='fromQuaternion') + if (dNeq(norm2(qu),1.0_pREAL,1.0e-8_pREAL)) call IO_error(402,ext_msg='fromQuaternion') self%q = qu @@ -172,15 +172,15 @@ end subroutine fromQuaternion subroutine fromEulers(self,eu,degrees) class(tRotation), intent(out) :: self - real(pReal), dimension(3), intent(in) :: eu + real(pREAL), dimension(3), intent(in) :: eu logical, intent(in), optional :: degrees - real(pReal), dimension(3) :: Eulers + real(pREAL), dimension(3) :: Eulers Eulers = merge(eu*INRAD,eu,misc_optional(degrees,.false.)) - if (any(Eulers<0.0_pReal) .or. any(Eulers>TAU) .or. Eulers(2) > PI) & + if (any(Eulers<0.0_pREAL) .or. any(Eulers>TAU) .or. Eulers(2) > PI) & call IO_error(402,ext_msg='fromEulers') self%q = eu2qu(Eulers) @@ -190,20 +190,20 @@ end subroutine fromEulers subroutine fromAxisAngle(self,ax,degrees,P) class(tRotation), intent(out) :: self - real(pReal), dimension(4), intent(in) :: ax + real(pREAL), dimension(4), intent(in) :: ax logical, intent(in), optional :: degrees integer, intent(in), optional :: P - real(pReal) :: angle - real(pReal),dimension(3) :: axis + real(pREAL) :: angle + real(pREAL),dimension(3) :: axis angle = merge(ax(4)*INRAD,ax(4),misc_optional(degrees,.false.)) - axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,misc_optional(P,-1) == 1) + axis = ax(1:3) * merge(-1.0_pREAL,1.0_pREAL,misc_optional(P,-1) == 1) if (abs(misc_optional(P,-1)) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') - if (dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & + if (dNeq(norm2(axis),1.0_pREAL) .or. angle < 0.0_pREAL .or. angle > PI) & call IO_error(402,ext_msg='fromAxisAngle') self%q = ax2qu([axis,angle]) @@ -213,10 +213,10 @@ end subroutine fromAxisAngle subroutine fromMatrix(self,om) class(tRotation), intent(out) :: self - real(pReal), dimension(3,3), intent(in) :: om + real(pREAL), dimension(3,3), intent(in) :: om - if (dNeq(math_det33(om),1.0_pReal,tol=1.0e-5_pReal)) & + if (dNeq(math_det33(om),1.0_pREAL,tol=1.0e-5_pREAL)) & call IO_error(402,ext_msg='fromMatrix') self%q = om2qu(om) @@ -248,7 +248,7 @@ pure elemental subroutine standardize(self) class(tRotation), intent(inout) :: self - if (sign(1.0_pReal,self%q(1)) < 0.0_pReal) self%q = - self%q + if (sign(1.0_pREAL,self%q(1)) < 0.0_pREAL) self%q = - self%q end subroutine standardize @@ -259,18 +259,18 @@ end subroutine standardize !-------------------------------------------------------------------------------------------------- pure function rotVector(self,v,active) result(vRot) - real(pReal), dimension(3) :: vRot + real(pREAL), dimension(3) :: vRot class(tRotation), intent(in) :: self - real(pReal), intent(in), dimension(3) :: v + real(pREAL), intent(in), dimension(3) :: v logical, intent(in), optional :: active - real(pReal), dimension(4) :: v_normed, q + real(pREAL), dimension(4) :: v_normed, q if (dEq0(norm2(v))) then vRot = v else - v_normed = [0.0_pReal,v]/norm2(v) + v_normed = [0.0_pREAL,v]/norm2(v) q = merge(multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), & multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), & misc_optional(active,.false.)) @@ -287,9 +287,9 @@ end function rotVector !-------------------------------------------------------------------------------------------------- pure function rotTensor2(self,T,active) result(tRot) - real(pReal), dimension(3,3) :: tRot + real(pREAL), dimension(3,3) :: tRot class(tRotation), intent(in) :: self - real(pReal), intent(in), dimension(3,3) :: T + real(pREAL), intent(in), dimension(3,3) :: T logical, intent(in), optional :: active @@ -307,17 +307,17 @@ end function rotTensor2 !-------------------------------------------------------------------------------------------------- pure function rotTensor4(self,T,active) result(tRot) - real(pReal), dimension(3,3,3,3) :: tRot + real(pREAL), dimension(3,3,3,3) :: tRot class(tRotation), intent(in) :: self - real(pReal), intent(in), dimension(3,3,3,3) :: T + real(pREAL), intent(in), dimension(3,3,3,3) :: T logical, intent(in), optional :: active - real(pReal), dimension(3,3) :: R + real(pREAL), dimension(3,3) :: R integer :: i,j,k,l,m,n,o,p R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) - tRot = 0.0_pReal + tRot = 0.0_pREAL do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3 do m = 1,3;do n = 1,3;do o = 1,3;do p = 1,3 tRot(i,j,k,l) = tRot(i,j,k,l) & @@ -334,13 +334,13 @@ end function rotTensor4 !-------------------------------------------------------------------------------------------------- pure function rotStiffness(self,C,active) result(cRot) - real(pReal), dimension(6,6) :: cRot + real(pREAL), dimension(6,6) :: cRot class(tRotation), intent(in) :: self - real(pReal), intent(in), dimension(6,6) :: C + real(pREAL), intent(in), dimension(6,6) :: C logical, intent(in), optional :: active - real(pReal), dimension(3,3) :: R - real(pReal), dimension(6,6) :: M + real(pREAL), dimension(3,3) :: R + real(pREAL), dimension(6,6) :: M R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) @@ -351,11 +351,11 @@ pure function rotStiffness(self,C,active) result(cRot) R(2,2)*R(3,2), R(1,2)*R(3,2), R(1,2)*R(2,2), & R(1,3)**2, R(2,3)**2, R(3,3)**2, & R(2,3)*R(3,3), R(1,3)*R(3,3), R(1,3)*R(2,3), & - 2.0_pReal*R(1,2)*R(1,3), 2.0_pReal*R(2,2)*R(2,3), 2.0_pReal*R(3,2)*R(3,3), & + 2.0_pREAL*R(1,2)*R(1,3), 2.0_pREAL*R(2,2)*R(2,3), 2.0_pREAL*R(3,2)*R(3,3), & R(2,2)*R(3,3)+R(2,3)*R(3,2), R(1,2)*R(3,3)+R(1,3)*R(3,2), R(1,2)*R(2,3)+R(1,3)*R(2,2), & - 2.0_pReal*R(1,3)*R(1,1), 2.0_pReal*R(2,3)*R(2,1), 2.0_pReal*R(3,3)*R(3,1), & + 2.0_pREAL*R(1,3)*R(1,1), 2.0_pREAL*R(2,3)*R(2,1), 2.0_pREAL*R(3,3)*R(3,1), & R(2,3)*R(3,1)+R(2,1)*R(3,3), R(1,3)*R(3,1)+R(1,1)*R(3,3), R(1,3)*R(2,1)+R(1,1)*R(2,3), & - 2.0_pReal*R(1,1)*R(1,2), 2.0_pReal*R(2,1)*R(2,2), 2.0_pReal*R(3,1)*R(3,2), & + 2.0_pREAL*R(1,1)*R(1,2), 2.0_pREAL*R(2,1)*R(2,2), 2.0_pREAL*R(3,1)*R(3,2), & R(2,1)*R(3,2)+R(2,2)*R(3,1), R(1,1)*R(3,2)+R(1,2)*R(3,1), R(1,1)*R(2,2)+R(1,2)*R(2,1)],[6,6]) cRot = matmul(M,matmul(C,transpose(M))) @@ -383,27 +383,27 @@ end function misorientation !-------------------------------------------------------------------------------------------------- pure function qu2om(qu) result(om) - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(3,3) :: om + real(pREAL), intent(in), dimension(4) :: qu + real(pREAL), dimension(3,3) :: om - real(pReal) :: qq + real(pREAL) :: qq qq = qu(1)**2-sum(qu(2:4)**2) - om(1,1) = qq+2.0_pReal*qu(2)**2 - om(2,2) = qq+2.0_pReal*qu(3)**2 - om(3,3) = qq+2.0_pReal*qu(4)**2 + om(1,1) = qq+2.0_pREAL*qu(2)**2 + om(2,2) = qq+2.0_pREAL*qu(3)**2 + om(3,3) = qq+2.0_pREAL*qu(4)**2 - om(1,2) = 2.0_pReal*(qu(2)*qu(3)-qu(1)*qu(4)) - om(2,3) = 2.0_pReal*(qu(3)*qu(4)-qu(1)*qu(2)) - om(3,1) = 2.0_pReal*(qu(4)*qu(2)-qu(1)*qu(3)) - om(2,1) = 2.0_pReal*(qu(3)*qu(2)+qu(1)*qu(4)) - om(3,2) = 2.0_pReal*(qu(4)*qu(3)+qu(1)*qu(2)) - om(1,3) = 2.0_pReal*(qu(2)*qu(4)+qu(1)*qu(3)) + om(1,2) = 2.0_pREAL*(qu(2)*qu(3)-qu(1)*qu(4)) + om(2,3) = 2.0_pREAL*(qu(3)*qu(4)-qu(1)*qu(2)) + om(3,1) = 2.0_pREAL*(qu(4)*qu(2)-qu(1)*qu(3)) + om(2,1) = 2.0_pREAL*(qu(3)*qu(2)+qu(1)*qu(4)) + om(3,2) = 2.0_pREAL*(qu(4)*qu(3)+qu(1)*qu(2)) + om(1,3) = 2.0_pREAL*(qu(2)*qu(4)+qu(1)*qu(3)) - if (sign(1.0_pReal,P) < 0.0_pReal) om = transpose(om) - om = om/math_det33(om)**(1.0_pReal/3.0_pReal) + if (sign(1.0_pREAL,P) < 0.0_pREAL) om = transpose(om) + om = om/math_det33(om)**(1.0_pREAL/3.0_pREAL) end function qu2om @@ -414,10 +414,10 @@ end function qu2om !-------------------------------------------------------------------------------------------------- pure function qu2eu(qu) result(eu) - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(3) :: eu + real(pREAL), intent(in), dimension(4) :: qu + real(pREAL), dimension(3) :: eu - real(pReal) :: q12, q03, chi + real(pREAL) :: q12, q03, chi q03 = qu(1)**2+qu(4)**2 @@ -425,15 +425,15 @@ pure function qu2eu(qu) result(eu) chi = sqrt(q03*q12) degenerated: if (dEq0(q12)) then - eu = [atan2(-P*2.0_pReal*qu(1)*qu(4),qu(1)**2-qu(4)**2), 0.0_pReal, 0.0_pReal] + eu = [atan2(-P*2.0_pREAL*qu(1)*qu(4),qu(1)**2-qu(4)**2), 0.0_pREAL, 0.0_pREAL] elseif (dEq0(q03)) then - eu = [atan2( 2.0_pReal*qu(2)*qu(3),qu(2)**2-qu(3)**2), PI, 0.0_pReal] + eu = [atan2( 2.0_pREAL*qu(2)*qu(3),qu(2)**2-qu(3)**2), PI, 0.0_pREAL] else degenerated eu = [atan2((-P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)-qu(3)*qu(4))*chi ), & - atan2( 2.0_pReal*chi, q03-q12 ), & + atan2( 2.0_pREAL*chi, q03-q12 ), & atan2(( P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)+qu(3)*qu(4))*chi )] end if degenerated - where(sign(1.0_pReal,eu)<0.0_pReal) eu = mod(eu+TAU,[TAU,PI,TAU]) + where(sign(1.0_pREAL,eu)<0.0_pREAL) eu = mod(eu+TAU,[TAU,PI,TAU]) end function qu2eu @@ -444,17 +444,17 @@ end function qu2eu !-------------------------------------------------------------------------------------------------- pure function qu2ax(qu) result(ax) - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(4) :: ax + real(pREAL), intent(in), dimension(4) :: qu + real(pREAL), dimension(4) :: ax - real(pReal) :: omega, s + real(pREAL) :: omega, s if (dEq0(sum(qu(2:4)**2))) then - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] ! axis = [001] + ax = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL, 0.0_pREAL ] ! axis = [001] elseif (dNeq0(qu(1))) then - s = sign(1.0_pReal,qu(1))/norm2(qu(2:4)) - omega = 2.0_pReal * acos(math_clip(qu(1),-1.0_pReal,1.0_pReal)) + s = sign(1.0_pREAL,qu(1))/norm2(qu(2:4)) + omega = 2.0_pREAL * acos(math_clip(qu(1),-1.0_pREAL,1.0_pREAL)) ax = [ qu(2)*s, qu(3)*s, qu(4)*s, omega ] else ax = [ qu(2), qu(3), qu(4), PI ] @@ -470,29 +470,29 @@ end function qu2ax !-------------------------------------------------------------------------------------------------- pure function om2qu(om) result(qu) - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(4) :: qu + real(pREAL), intent(in), dimension(3,3) :: om + real(pREAL), dimension(4) :: qu - real(pReal) :: trace,s + real(pREAL) :: trace,s trace = math_trace33(om) - if (trace > 0.0_pReal) then - s = 0.5_pReal / sqrt(trace+1.0_pReal) - qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] + if (trace > 0.0_pREAL) then + s = 0.5_pREAL / sqrt(trace+1.0_pREAL) + qu = [0.25_pREAL/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] else if ( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then - s = 2.0_pReal * sqrt( 1.0_pReal + om(1,1) - om(2,2) - om(3,3)) - qu = [ (om(3,2) - om(2,3)) /s,0.25_pReal * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s] + s = 2.0_pREAL * sqrt( 1.0_pREAL + om(1,1) - om(2,2) - om(3,3)) + qu = [ (om(3,2) - om(2,3)) /s,0.25_pREAL * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s] elseif (om(2,2) > om(3,3)) then - s = 2.0_pReal * sqrt( 1.0_pReal + om(2,2) - om(1,1) - om(3,3)) - qu = [ (om(1,3) - om(3,1)) /s,(om(1,2) + om(2,1)) / s,0.25_pReal * s,(om(2,3) + om(3,2)) / s] + s = 2.0_pREAL * sqrt( 1.0_pREAL + om(2,2) - om(1,1) - om(3,3)) + qu = [ (om(1,3) - om(3,1)) /s,(om(1,2) + om(2,1)) / s,0.25_pREAL * s,(om(2,3) + om(3,2)) / s] else - s = 2.0_pReal * sqrt( 1.0_pReal + om(3,3) - om(1,1) - om(2,2) ) - qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s] + s = 2.0_pREAL * sqrt( 1.0_pREAL + om(3,3) - om(1,1) - om(2,2) ) + qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pREAL * s] end if end if - if (sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu + if (sign(1.0_pREAL,qu(1))<0.0_pREAL) qu =-1.0_pREAL * qu qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4))) qu = qu/norm2(qu) @@ -506,21 +506,21 @@ end function om2qu !-------------------------------------------------------------------------------------------------- pure function om2eu(om) result(eu) - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: eu - real(pReal) :: zeta + real(pREAL), intent(in), dimension(3,3) :: om + real(pREAL), dimension(3) :: eu + real(pREAL) :: zeta - if (dNeq(abs(om(3,3)),1.0_pReal,1.e-8_pReal)) then - zeta = 1.0_pReal/sqrt(math_clip(1.0_pReal-om(3,3)**2,1e-64_pReal,1.0_pReal)) + if (dNeq(abs(om(3,3)),1.0_pREAL,1.e-8_pREAL)) then + zeta = 1.0_pREAL/sqrt(math_clip(1.0_pREAL-om(3,3)**2,1e-64_pREAL,1.0_pREAL)) eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), & - acos(math_clip(om(3,3),-1.0_pReal,1.0_pReal)), & + acos(math_clip(om(3,3),-1.0_pREAL,1.0_pREAL)), & atan2(om(1,3)*zeta, om(2,3)*zeta)] else - eu = [atan2(om(1,2),om(1,1)), 0.5_pReal*PI*(1.0_pReal-om(3,3)),0.0_pReal ] + eu = [atan2(om(1,2),om(1,1)), 0.5_pREAL*PI*(1.0_pREAL-om(3,3)),0.0_pREAL ] end if - where(abs(eu) < 1.e-8_pReal) eu = 0.0_pReal - where(sign(1.0_pReal,eu)<0.0_pReal) eu = mod(eu+TAU,[TAU,PI,TAU]) + where(abs(eu) < 1.e-8_pREAL) eu = 0.0_pREAL + where(sign(1.0_pREAL,eu)<0.0_pREAL) eu = mod(eu+TAU,[TAU,PI,TAU]) end function om2eu @@ -531,28 +531,28 @@ end function om2eu !-------------------------------------------------------------------------------------------------- function om2ax(om) result(ax) - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(4) :: ax + real(pREAL), intent(in), dimension(3,3) :: om + real(pREAL), dimension(4) :: ax - real(pReal) :: t - real(pReal), dimension(3) :: Wr, Wi - real(pReal), dimension((64+2)*3) :: work - real(pReal), dimension(3,3) :: VR, devNull, om_ + real(pREAL) :: t + real(pREAL), dimension(3) :: Wr, Wi + real(pREAL), dimension((64+2)*3) :: work + real(pREAL), dimension(3,3) :: VR, devNull, om_ integer :: ierr, i om_ = om ! first get the rotation angle - t = 0.5_pReal * (math_trace33(om) - 1.0_pReal) - ax(4) = acos(math_clip(t,-1.0_pReal,1.0_pReal)) + t = 0.5_pREAL * (math_trace33(om) - 1.0_pREAL) + ax(4) = acos(math_clip(t,-1.0_pREAL,1.0_pREAL)) if (dEq0(ax(4))) then - ax(1:3) = [ 0.0_pReal, 0.0_pReal, 1.0_pReal ] + ax(1:3) = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL ] else call dgeev('N','V',3,om_,3,Wr,Wi,devNull,3,VR,3,work,size(work,1),ierr) if (ierr /= 0) error stop 'LAPACK error' - i = findloc(cEq(cmplx(Wr,Wi,pReal),cmplx(1.0_pReal,0.0_pReal,pReal),tol=1.0e-14_pReal),.true.,dim=1) !find eigenvalue (1,0) + i = findloc(cEq(cmplx(Wr,Wi,pREAL),cmplx(1.0_pREAL,0.0_pREAL,pREAL),tol=1.0e-14_pREAL),.true.,dim=1) !find eigenvalue (1,0) if (i == 0) error stop 'om2ax conversion failed' ax(1:3) = VR(1:3,i) where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) & @@ -568,13 +568,13 @@ end function om2ax !-------------------------------------------------------------------------------------------------- pure function eu2qu(eu) result(qu) - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(4) :: qu - real(pReal), dimension(3) :: ee - real(pReal) :: cPhi, sPhi + real(pREAL), intent(in), dimension(3) :: eu + real(pREAL), dimension(4) :: qu + real(pREAL), dimension(3) :: ee + real(pREAL) :: cPhi, sPhi - ee = 0.5_pReal*eu + ee = 0.5_pREAL*eu cPhi = cos(ee(2)) sPhi = sin(ee(2)) @@ -583,7 +583,7 @@ pure function eu2qu(eu) result(qu) -P*sPhi*cos(ee(1)-ee(3)), & -P*sPhi*sin(ee(1)-ee(3)), & -P*cPhi*sin(ee(1)+ee(3))] - if (sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal) + if (sign(1.0_pREAL,qu(1)) < 0.0_pREAL) qu = qu * (-1.0_pREAL) end function eu2qu @@ -594,10 +594,10 @@ end function eu2qu !-------------------------------------------------------------------------------------------------- pure function eu2om(eu) result(om) - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3,3) :: om + real(pREAL), intent(in), dimension(3) :: eu + real(pREAL), dimension(3,3) :: om - real(pReal), dimension(3) :: c, s + real(pREAL), dimension(3) :: c, s c = cos(eu) @@ -613,7 +613,7 @@ pure function eu2om(eu) result(om) om(2,3) = c(3)*s(2) om(3,3) = c(2) - where(abs(om)<1.0e-12_pReal) om = 0.0_pReal + where(abs(om)<1.0e-12_pREAL) om = 0.0_pREAL end function eu2om @@ -624,25 +624,25 @@ end function eu2om !-------------------------------------------------------------------------------------------------- pure function eu2ax(eu) result(ax) - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(4) :: ax + real(pREAL), intent(in), dimension(3) :: eu + real(pREAL), dimension(4) :: ax - real(pReal) :: t, delta, tau, alpha, sigma + real(pREAL) :: t, delta, tau, alpha, sigma - t = tan(eu(2)*0.5_pReal) - sigma = 0.5_pReal*(eu(1)+eu(3)) - delta = 0.5_pReal*(eu(1)-eu(3)) + t = tan(eu(2)*0.5_pREAL) + sigma = 0.5_pREAL*(eu(1)+eu(3)) + delta = 0.5_pREAL*(eu(1)-eu(3)) tau = sqrt(t**2+sin(sigma)**2) - alpha = merge(PI, 2.0_pReal*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pReal,tol=1.0e-15_pReal)) + alpha = merge(PI, 2.0_pREAL*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pREAL,tol=1.0e-15_pREAL)) if (dEq0(alpha)) then ! return a default identity axis-angle pair - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] + ax = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL, 0.0_pREAL ] else ax(1:3) = -P/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ] ! passive axis-angle pair so a minus sign in front ax(4) = alpha - if (sign(1.0_pReal,alpha) < 0.0_pReal) ax = -ax ! ensure alpha is positive + if (sign(1.0_pREAL,alpha) < 0.0_pREAL) ax = -ax ! ensure alpha is positive end if end function eu2ax @@ -654,17 +654,17 @@ end function eu2ax !-------------------------------------------------------------------------------------------------- pure function ax2qu(ax) result(qu) - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(4) :: qu + real(pREAL), intent(in), dimension(4) :: ax + real(pREAL), dimension(4) :: qu - real(pReal) :: c, s + real(pREAL) :: c, s if (dEq0(ax(4))) then - qu = [ 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal ] + qu = [ 1.0_pREAL, 0.0_pREAL, 0.0_pREAL, 0.0_pREAL ] else - c = cos(ax(4)*0.5_pReal) - s = sin(ax(4)*0.5_pReal) + c = cos(ax(4)*0.5_pREAL) + s = sin(ax(4)*0.5_pREAL) qu = [ c, ax(1)*s, ax(2)*s, ax(3)*s ] end if @@ -677,15 +677,15 @@ end function ax2qu !-------------------------------------------------------------------------------------------------- pure function ax2om(ax) result(om) - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3,3) :: om + real(pREAL), intent(in), dimension(4) :: ax + real(pREAL), dimension(3,3) :: om - real(pReal) :: q, c, s, omc + real(pREAL) :: q, c, s, omc c = cos(ax(4)) s = sin(ax(4)) - omc = 1.0_pReal-c + omc = 1.0_pREAL-c om(1,1) = ax(1)**2*omc + c om(2,2) = ax(2)**2*omc + c @@ -703,7 +703,7 @@ pure function ax2om(ax) result(om) om(3,1) = q + s*ax(2) om(1,3) = q - s*ax(2) - if (P > 0.0_pReal) om = transpose(om) + if (P > 0.0_pREAL) om = transpose(om) end function ax2om @@ -714,8 +714,8 @@ end function ax2om !-------------------------------------------------------------------------------------------------- pure function ax2eu(ax) result(eu) - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: eu + real(pREAL), intent(in), dimension(4) :: ax + real(pREAL), dimension(3) :: eu eu = om2eu(ax2om(ax)) @@ -728,8 +728,8 @@ end function ax2eu !-------------------------------------------------------------------------------------------------- pure function multiplyQuaternion(qu1,qu2) - real(pReal), dimension(4), intent(in) :: qu1, qu2 - real(pReal), dimension(4) :: multiplyQuaternion + real(pREAL), dimension(4), intent(in) :: qu1, qu2 + real(pREAL), dimension(4) :: multiplyQuaternion multiplyQuaternion(1) = qu1(1)*qu2(1) - qu1(2)*qu2(2) - qu1(3)*qu2(3) - qu1(4)*qu2(4) @@ -745,8 +745,8 @@ end function multiplyQuaternion !-------------------------------------------------------------------------------------------------- pure function conjugateQuaternion(qu) - real(pReal), dimension(4), intent(in) :: qu - real(pReal), dimension(4) :: conjugateQuaternion + real(pREAL), dimension(4), intent(in) :: qu + real(pREAL), dimension(4) :: conjugateQuaternion conjugateQuaternion = [qu(1), -qu(2), -qu(3), -qu(4)] @@ -760,36 +760,36 @@ end function conjugateQuaternion subroutine selfTest() type(tRotation) :: R - real(pReal), dimension(4) :: qu - real(pReal), dimension(3) :: x, eu, v3 - real(pReal), dimension(3,3) :: om, t33 - real(pReal), dimension(3,3,3,3) :: t3333 - real(pReal), dimension(6,6) :: C - real(pReal) :: A,B + real(pREAL), dimension(4) :: qu + real(pREAL), dimension(3) :: x, eu, v3 + real(pREAL), dimension(3,3) :: om, t33 + real(pREAL), dimension(3,3,3,3) :: t3333 + real(pREAL), dimension(6,6) :: C + real(pREAL) :: A,B integer :: i do i = 1, 20 if (i==1) then - qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] + qu = [1.0_pREAL, 0.0_pREAL, 0.0_pREAL, 0.0_pREAL] elseif (i==2) then - qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal] + qu = [1.0_pREAL,-0.0_pREAL,-0.0_pREAL,-0.0_pREAL] elseif (i==3) then - qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] + qu = [0.0_pREAL, 1.0_pREAL, 0.0_pREAL, 0.0_pREAL] elseif (i==4) then - qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal] + qu = [0.0_pREAL,0.0_pREAL,1.0_pREAL,0.0_pREAL] elseif (i==5) then - qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal] + qu = [0.0_pREAL, 0.0_pREAL, 0.0_pREAL, 1.0_pREAL] else call random_number(x) A = sqrt(x(3)) - B = sqrt(1-0_pReal -x(3)) + B = sqrt(1-0_pREAL -x(3)) qu = [cos(TAU*x(1))*A,& sin(TAU*x(2))*B,& cos(TAU*x(2))*B,& sin(TAU*x(1))*A] - if (qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) + if (qu(1)<0.0_pREAL) qu = qu * (-1.0_pREAL) end if @@ -807,24 +807,24 @@ subroutine selfTest() call R%fromMatrix(om) call random_number(v3) - if (any(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pReal))) & + if (any(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pREAL))) & error stop 'rotVector' call random_number(t33) - if (any(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pReal))) & + if (any(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pREAL))) & error stop 'rotTensor2' call random_number(t3333) - if (any(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pReal))) & + if (any(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pREAL))) & error stop 'rotTensor4' call random_number(C) C = C+transpose(C) if (any(dNeq(R%rotStiffness(C), & - math_3333toVoigt66_stiffness(R%rotate(math_Voigt66to3333_stiffness(C))),1.0e-12_pReal))) & + math_3333toVoigt66_stiffness(R%rotate(math_Voigt66to3333_stiffness(C))),1.0e-12_pREAL))) & error stop 'rotStiffness' - call R%fromQuaternion(qu * (1.0_pReal + merge(+5.e-9_pReal,-5.e-9_pReal, mod(i,2) == 0))) ! allow reasonable tolerance for ASCII/YAML + call R%fromQuaternion(qu * (1.0_pREAL + merge(+5.e-9_pREAL,-5.e-9_pREAL, mod(i,2) == 0))) ! allow reasonable tolerance for ASCII/YAML end do @@ -832,12 +832,12 @@ subroutine selfTest() pure recursive function quaternion_equal(qu1,qu2) result(ok) - real(pReal), intent(in), dimension(4) :: qu1,qu2 + real(pREAL), intent(in), dimension(4) :: qu1,qu2 logical :: ok - ok = all(dEq(qu1,qu2,1.0e-7_pReal)) - if (dEq0(qu1(1),1.0e-12_pReal)) & - ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal)) + ok = all(dEq(qu1,qu2,1.0e-7_pREAL)) + if (dEq0(qu1(1),1.0e-12_pREAL)) & + ok = ok .or. all(dEq(-1.0_pREAL*qu1,qu2,1.0e-7_pREAL)) end function quaternion_equal diff --git a/src/tables.f90 b/src/tables.f90 index b4e63e303..65bd7e514 100644 --- a/src/tables.f90 +++ b/src/tables.f90 @@ -13,7 +13,7 @@ module tables private type, public :: tTable - real(pReal), dimension(:), allocatable :: x,y + real(pREAL), dimension(:), allocatable :: x,y contains procedure, public :: at => eval end type tTable @@ -47,7 +47,7 @@ end subroutine tables_init !-------------------------------------------------------------------------------------------------- function table_from_values(x,y) result(t) - real(pReal), dimension(:), intent(in) :: x,y + real(pREAL), dimension(:), intent(in) :: x,y type(tTable) :: t @@ -55,7 +55,7 @@ function table_from_values(x,y) result(t) if (size(y) < 1) call IO_error(603,ext_msg='missing tabulated y data') if (size(x) /= size(y)) call IO_error(603,ext_msg='shape mismatch in tabulated data') if (size(x) /= 1) then - if (any(x(2:size(x))-x(1:size(x)-1) <= 0.0_pReal)) & + if (any(x(2:size(x))-x(1:size(x)-1) <= 0.0_pREAL)) & call IO_error(603,ext_msg='ordinate data does not increase monotonically') end if @@ -86,8 +86,8 @@ end function table_from_dict pure function eval(self,x) result(y) class(tTable), intent(in) :: self - real(pReal), intent(in) :: x - real(pReal) :: y + real(pREAL), intent(in) :: x + real(pREAL) :: y integer :: i @@ -109,25 +109,25 @@ end function eval subroutine selfTest() type(tTable) :: t - real(pReal), dimension(*), parameter :: & - x = real([ 1., 2., 3., 4.],pReal), & - y = real([ 1., 3., 2.,-2.],pReal), & - x_eval = real([ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0],pReal), & - y_true = real([-1.0, 0.0, 1.0, 2.0, 3.0, 2.5 ,2.0, 0.0,-2.0,-4.0,-6.0],pReal) + real(pREAL), dimension(*), parameter :: & + x = real([ 1., 2., 3., 4.],pREAL), & + y = real([ 1., 3., 2.,-2.],pREAL), & + x_eval = real([ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0],pREAL), & + y_true = real([-1.0, 0.0, 1.0, 2.0, 3.0, 2.5 ,2.0, 0.0,-2.0,-4.0,-6.0],pREAL) integer :: i type(tDict), pointer :: dict type(tList), pointer :: l_x, l_y - real(pReal) :: r + real(pREAL) :: r call random_number(r) - t = table(real([0.],pReal),real([r],pReal)) - if (dNeq(r,t%at(r),1.0e-9_pReal)) error stop 'table eval/mono' + t = table(real([0.],pREAL),real([r],pREAL)) + if (dNeq(r,t%at(r),1.0e-9_pREAL)) error stop 'table eval/mono' - r = r-0.5_pReal + r = r-0.5_pREAL t = table(x+r,y) do i = 1, size(x_eval) - if (dNeq(y_true(i),t%at(x_eval(i)+r),1.0e-9_pReal)) error stop 'table eval/values' + if (dNeq(y_true(i),t%at(x_eval(i)+r),1.0e-9_pREAL)) error stop 'table eval/values' end do l_x => YAML_parse_str_asList('[1, 2, 3, 4]'//IO_EOL) diff --git a/src/test/test_HDF5_utilities.f90 b/src/test/test_HDF5_utilities.f90 index 815bbe671..94e4175ce 100644 --- a/src/test/test_HDF5_utilities.f90 +++ b/src/test/test_HDF5_utilities.f90 @@ -22,7 +22,7 @@ end subroutine HDF5_utilities_test subroutine test_read_write() integer(HID_T) :: f - real(pReal), dimension(3) :: d_in,d_out + real(pREAL), dimension(3) :: d_in,d_out call random_number(d_in) From fd55fe2b9f371b33fba65c7e2e68b1b88b97e0e1 Mon Sep 17 00:00:00 2001 From: Test User Date: Mon, 5 Jun 2023 10:24:19 +0200 Subject: [PATCH 6/7] [skip ci] updated version information after successful test of v3.0.0-alpha7-537-g1eee3d3ee --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 495329abd..d31504fd6 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -3.0.0-alpha7-534-g51210a05e +3.0.0-alpha7-537-g1eee3d3ee From bafbba4b585361d5775b98ba5d6641a083c87594 Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 6 Jun 2023 23:45:19 +0200 Subject: [PATCH 7/7] [skip ci] updated version information after successful test of v3.0.0-alpha7-544-g58ee3312c --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index d31504fd6..a41a3d48a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -3.0.0-alpha7-537-g1eee3d3ee +3.0.0-alpha7-544-g58ee3312c