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

Merge branch 'fortran-rename' into 'development' 

following style guide

See merge request damask/DAMASK!674
This commit is contained in:
Daniel Otto de Mentock 2022-12-02 14:19:24 +00:00
parent fd2b892f3e 411c86b5ef
commit 934147d803
15 changed files with 225 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/Marc/DAMASK_Marc.f90
View File

@ -70,7 +70,7 @@ subroutine DAMASK_interface_init
if (ierr /= 0) then
print*, 'working directory "'//trim(wd)//'" does not exist'
call quit(1)
endif
end if
symmetricSolver = solverIsSymmetric()
end subroutine DAMASK_interface_init
@ -111,8 +111,8 @@ logical function solverIsSymmetric()
s = s + verify(line(s+1:),' ') ! start of second chunk
e = s + scan (line(s+1:),' ') ! end of second chunk
solverIsSymmetric = line(s:e) /= '1'
endif
enddo
end if
end do
100 close(fileUnit)
contains
@ -134,7 +134,7 @@ logical function solverIsSymmetric()
lc(i:i) = string(i:i)
n = index(UPPER,lc(i:i))
if (n/=0) lc(i:i) = LOWER(n:n)
enddo
end do
end function lc
end function solverIsSymmetric
@ -299,7 +299,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
transpose(ffn)
write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', &
transpose(ffn1)
endif
end if
defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc
call omp_set_num_threads(1_pI32) ! no openMP
@ -309,7 +309,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
call materialpoint_initAll
debug_Marc => config_debug%get_list('Marc',defaultVal=emptyList)
debug_basic = debug_Marc%contains('basic')
endif
end if
computationMode = 0 ! save initialization value, since it does not result in any calculation
if (lovl == 4 ) then ! jacobian requested by marc
@ -333,35 +333,35 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
lastIncConverged = .true.
outdatedByNewInc = .true.
print'(a,i6,1x,i2)', '<< HYPELA2 >> new increment..! ',m(1),nn
endif
end if
else if ( timinc < theDelta ) then ! >> cutBack <<
lastIncConverged = .false.
outdatedByNewInc = .false.
terminallyIll = .false.
cycleCounter = -1 ! first calc step increments this to cycle = 0
print'(a,i6,1x,i2)', '<< HYPELA2 >> cutback detected..! ',m(1),nn
endif ! convergence treatment end
end if ! convergence treatment end
flush(6)
if (lastLovl /= lovl) then
cycleCounter = cycleCounter + 1
!mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates
!call mesh_build_ipCoordinates() ! update ip coordinates
endif
end if
if (outdatedByNewInc) then
computationMode = ior(computationMode,materialpoint_AGERESULTS)
outdatedByNewInc = .false.
endif
end if
if (lastIncConverged) then
computationMode = ior(computationMode,materialpoint_BACKUPJACOBIAN)
lastIncConverged = .false.
endif
end if
theTime = cptim
theDelta = timinc
theInc = inc
endif
end if
lastLovl = lovl
call materialpoint_general(computationMode,ffn,ffn1,t(1),timinc,int(m(1)),int(nn),stress,ddsdde)
@ -429,13 +429,13 @@ subroutine uedinc(inc,incsub)
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
endif
enddo
end if
end do
call discretization_Marc_UpdateNodeAndIpCoords(d_n)
call materialpoint_results(int(inc),cptim)
inc_written = int(inc)
endif
end if
end subroutine uedinc

180
src/Marc/discretization_Marc.f90
View File

@ -275,8 +275,8 @@ subroutine inputRead_fileFormat(fileFormat,fileContent)
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then
fileFormat = IO_intValue(fileContent(l),chunkPos,2)
exit
endif
enddo
end if
end do
end subroutine inputRead_fileFormat
@ -302,8 +302,8 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent)
initialcond = IO_intValue(fileContent(l),chunkPos,4)
hypoelastic = IO_intValue(fileContent(l),chunkPos,5)
exit
endif
enddo
end if
end do
end subroutine inputRead_tableStyles
@ -331,16 +331,16 @@ subroutine inputRead_matNumber(matNumber, &
data_blocks = IO_intValue(fileContent(l+1),chunkPos,1)
else
data_blocks = 1
endif
end if
allocate(matNumber(data_blocks), source = 0)
do i = 0, data_blocks - 1
j = i*(2+tableStyle) + 1
chunkPos = IO_stringPos(fileContent(l+1+j))
matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1)
enddo
end do
exit
endif
enddo
end if
end do
end subroutine inputRead_matNumber
@ -368,8 +368,8 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,&
elseif(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = IO_stringPos(fileContent(l+1))
nNodes = IO_IntValue (fileContent(l+1),chunkPos,2)
endif
enddo
end if
end do
end subroutine inputRead_NnodesAndElements
@ -411,12 +411,12 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
if(IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value
elemInCurrentSet = elemInCurrentSet + 1 ! data ended
exit
endif
enddo
endif
end if
end do
end if
maxNelemInSet = max(maxNelemInSet, elemInCurrentSet)
endif
enddo
end if
end do
end subroutine inputRead_NelemSets
@ -448,8 +448,8 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,&
elemSet = elemSet+1
nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4))
mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet))
endif
enddo
end if
end do
end subroutine inputRead_mapElemSets
@ -484,17 +484,17 @@ subroutine inputRead_mapElems(FEM2DAMASK, &
j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j))
nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1)
enddo
enddo
end do
end do
exit
endif
enddo
end if
end do
call math_sort(map_unsorted)
allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
do i = 1, nElems
FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i)
enddo
end do
end subroutine inputRead_mapElems
@ -522,16 +522,16 @@ subroutine inputRead_mapNodes(FEM2DAMASK, &
chunkPos = [1,1,10]
do i = 1,nNodes
map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i]
enddo
end do
exit
endif
enddo
end if
end do
call math_sort(map_unsorted)
allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
do i = 1, nNodes
FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i)
enddo
end do
end subroutine inputRead_mapNodes
@ -560,10 +560,10 @@ subroutine inputRead_elemNodes(nodes, &
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)]
enddo
end do
exit
endif
enddo
end if
end do
end subroutine inputRead_elemNodes
@ -596,17 +596,17 @@ subroutine inputRead_elemType(elem, &
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)
endif
end if
remainingChunks = elem%nNodes - (chunkPos(1) - 2)
do while(remainingChunks > 0)
j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j))
remainingChunks = remainingChunks - chunkPos(1)
enddo
enddo
end do
end do
exit
endif
enddo
end if
end do
contains
@ -686,7 +686,7 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do k = 1,chunkPos(1)-2
inputRead_connectivityElem(k,e) = &
discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k+2))
enddo
end do
nNodesAlreadyRead = chunkPos(1) - 2
do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line
j = j + 1
@ -694,14 +694,14 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do k = 1,chunkPos(1)
inputRead_connectivityElem(nNodesAlreadyRead+k,e) = &
discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k))
enddo
end do
nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1)
enddo
endif
enddo
end do
end if
end do
exit
endif
enddo
end if
end do
end function inputRead_connectivityElem
@ -749,12 +749,12 @@ subroutine inputRead_material(materialAt,&
do i = 1,contInts(1)
e = discretization_Marc_FEM2DAMASK_elem(contInts(1+i))
materialAt(e) = ID + 1
enddo
end do
if (initialcondTableStyle == 0) m = m + 1
enddo
endif
endif
enddo
end do
end if
end if
end do
if(any(materialAt < 1)) call IO_error(180)
@ -791,9 +791,9 @@ pure subroutine buildCells(connectivity,definition, &
do c = 1, elem%NcellNodes
realNode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then
where(connectivity(:,:,e) == -c) connectivity(:,:,e) = connectivity_elem(c,e)
endif realNode
enddo
enddo
end if realNode
end do
end do
nCellNode = maxval(connectivity_elem)
@ -806,7 +806,7 @@ pure subroutine buildCells(connectivity,definition, &
do c = 1, elem%NcellNodes
if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nParentNodes) &
candidates_local = [candidates_local,c]
enddo
end do
s = size(candidates_local)
if (allocated(candidates_global)) deallocate(candidates_global)
@ -822,8 +822,8 @@ pure subroutine buildCells(connectivity,definition, &
if (elem%cellNodeParentNodeWeights(j,c) /= 0) then ! real node 'j' partly defines cell node 'c'
p = p + 1
parentsAndWeights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)]
endif
enddo
end if
end do
! store (and order) real node IDs and their weights together with the element number and local ID
do p = 1, nParentNodes
m = maxloc(parentsAndWeights(:,1),1)
@ -833,9 +833,9 @@ pure subroutine buildCells(connectivity,definition, &
candidates_global(nParentNodes*2+1:nParentNodes*2+2,candidateID) = [e,c]
parentsAndWeights(m,1) = -huge(parentsAndWeights(m,1)) ! out of the competition
enddo
enddo
enddo
end do
end do
end do
! sort according to real node IDs + weight (from left to right)
call math_sort(candidates_global,sortDim=1) ! sort according to first column
@ -847,13 +847,13 @@ pure subroutine buildCells(connectivity,definition, &
do while (n+j<= size(candidates_local)*Nelem)
if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit
j = j + 1
enddo
end do
e = n+j-1
if (any(candidates_global(p,n:e)/=candidates_global(p,n))) &
call math_sort(candidates_global(:,n:e),sortDim=p)
n = e+1
enddo
enddo
end do
end do
i = uniqueRows(candidates_global(1:2*nParentNodes,:))
allocate(definition(nParentNodes-1)%parents(i,nParentNodes))
@ -876,15 +876,15 @@ pure subroutine buildCells(connectivity,definition, &
end where
j = j+1
enddo
end do
nCellNode = nCellNode + 1
definition(nParentNodes-1)%parents(i,:) = parentsAndWeights(:,1)
definition(nParentNodes-1)%weights(i,:) = parentsAndWeights(:,2)
i = i + 1
n = n+j
enddo
end do
enddo
end do
contains
!------------------------------------------------------------------------------------------------
@ -906,10 +906,10 @@ pure subroutine buildCells(connectivity,definition, &
do while (r+d<= size(A,2))
if (any(A(:,r)/=A(:,r+d))) exit
d = d+1
enddo
end do
u = u+1
r = r+d
enddo
end do
end function uniqueRows
@ -939,10 +939,10 @@ pure function buildCellNodes(node_elem)
buildCellNodes(:,n) = buildCellNodes(:,n) &
+ buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) &
* real(cellNodeDefinition(i)%weights(j,k),pReal)
enddo
end do
buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal)
enddo
enddo
end do
end do
end function buildCellNodes
@ -970,9 +970,9 @@ pure function buildIPcoordinates(node_cell)
do n = 1, size(connectivity_cell_reshaped,1)
buildIPcoordinates(:,i) = buildIPcoordinates(:,i) &
+ node_cell(:,connectivity_cell_reshaped(n,i))
enddo
end do
buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal)
enddo
end do
end function buildIPcoordinates
@ -1031,8 +1031,8 @@ pure function IPvolume(elem,node)
+ dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0)))
IPvolume(i,e) = IPvolume(i,e)/12.0_pReal
end select
enddo
enddo
end do
end do
end function IPvolume
@ -1075,11 +1075,11 @@ pure function IPareaNormal(elem,nElem,node)
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
enddo
end do
end select
enddo
enddo
enddo
end do
end do
end do
end function IPareaNormal
@ -1109,10 +1109,10 @@ function IPneighborhood(elem)
do n = 1, size(face_unordered)
face(n,c) = minval(face_unordered)
face_unordered(minloc(face_unordered)) = huge(face_unordered)
enddo
end do
face(n:n+3,c) = [e,i,f]
enddo
enddo; enddo
end do
end do; end do
!--------------------------------------------------------------------------------------------------
! sort face definitions
@ -1125,17 +1125,17 @@ function IPneighborhood(elem)
if(any(face(:c,s) /= face(:c,e))) then
if(e-1/=s) call math_sort(face(:,s:e-1),sortDim=c)
s = e
endif
enddo
enddo
end if
end do
end do
IPneighborhood = 0
do c=1, size(face,2) - 1
if(all(face(:n-1,c) == face(:n-1,c+1))) then
IPneighborhood(:,face(n+2,c+1),face(n+1,c+1),face(n+0,c+1)) = face(n:n+3,c+0)
IPneighborhood(:,face(n+2,c+0),face(n+1,c+0),face(n+0,c+0)) = face(n:n+3,c+1)
endif
enddo
end if
end do
end function IPneighborhood
@ -1171,8 +1171,8 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
if (IO_stringValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name
continuousIntValues = lookupMap(:,i) ! return resp. entity list
exit
endif
enddo
end if
end do
exit
elseif(containsRange(fileContent(l),chunkPos)) then
first = IO_intValue(fileContent(l),chunkPos,1)
@ -1180,20 +1180,20 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
do i = first, last, sign(1,last-first)
continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = i
enddo
end do
exit
else
do i = 1,chunkPos(1)-1 ! interpret up to second to last value
continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,i)
enddo
end do
if ( IO_lc(IO_stringValue(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
endif
endif
enddo
end if
end if
end do
end function continuousIntValues
@ -1210,7 +1210,7 @@ logical function containsRange(str,chunkPos)
containsRange = .False.
if(chunkPos(1) == 3) then
if(IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True.
endif
end if
end function containsRange

14
src/Marc/materialpoint_Marc.f90
View File

@ -126,7 +126,7 @@ subroutine materialpoint_init
print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE)
print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood)
flush(IO_STDOUT)
endif
end if
end subroutine materialpoint_init
@ -171,7 +171,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
if (terminallyIll) &
print'(a,/)', '# --- terminallyIll --- #'
print'(a,/)', '#############################################'; flush (6)
endif
end if
if (iand(mode, materialpoint_BACKUPJACOBIAN) /= 0) &
materialpoint_dcsde_knownGood = materialpoint_dcsde
@ -220,15 +220,15 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
- 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) &
+ Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k))
enddo; enddo; enddo; enddo; enddo; enddo
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))
materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.)
endif terminalIllness
endif validCalculation
end if terminalIllness
end if validCalculation
if (debugmaterialpoint%extensive &
.and. ((debugmaterialpoint%element == elCP .and. debugmaterialpoint%ip == ip) .or. .not. debugmaterialpoint%selective)) then
@ -237,9 +237,9 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
print'(a,i8,1x,i2,/,6(12x,6(f10.3,1x)/))', &
'<< materialpoint >> Jacobian/GPa at elFE ip ', elFE, ip, transpose(materialpoint_dcsdE(1:6,1:6,ip,elCP))*1.0e-9_pReal
flush(IO_STDOUT)
endif
end if
endif
end if
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)

4
src/YAML_parse.f90
View File

@ -764,7 +764,7 @@ end subroutine dct
!--------------------------------------------------------------------------------------------------
! @brief decide whether next block is list or dict
! @brief Decide whether next block is list or dict.
!--------------------------------------------------------------------------------------------------
recursive subroutine decide(blck,flow,s_blck,s_flow,offset)
@ -811,7 +811,7 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset)
end if
end if
end subroutine
end subroutine decide
!--------------------------------------------------------------------------------------------------

66
src/grid/DAMASK_grid.f90
View File

@ -148,7 +148,7 @@ program DAMASK_grid
call results_openJobFile(parallel=.false.)
call results_writeDataset_str(fileContent,'setup',fname,'load case definition (grid solver)')
call results_closeJobFile
endif
end if
call parallelization_bcast_str(fileContent)
config_load => YAML_parse_str_asDict(fileContent)
@ -198,11 +198,11 @@ program DAMASK_grid
thermalActive: if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') then
field = field + 1
ID(field) = FIELD_THERMAL_ID
endif thermalActive
end if thermalActive
damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then
field = field + 1
ID(field) = FIELD_DAMAGE_ID
endif damageActive
end if damageActive
!--------------------------------------------------------------------------------------------------
@ -235,7 +235,7 @@ program DAMASK_grid
#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.)
enddo readMech
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')
@ -264,9 +264,9 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,12a)',advance='no') ' x '
else
write(IO_STDOUT,'(2x,f12.7)',advance='no') loadCases(l)%deformation%values(i,j)
endif
enddo; write(IO_STDOUT,'(/)',advance='no')
enddo
end if
end do; write(IO_STDOUT,'(/)',advance='no')
end do
if (any(loadCases(l)%stress%mask .eqv. loadCases(l)%deformation%mask)) errorID = 831
if (any(.not.(loadCases(l)%stress%mask .or. transpose(loadCases(l)%stress%mask)) .and. (math_I3<1))) &
errorID = 838 ! no rotation is allowed by stress BC
@ -280,10 +280,10 @@ program DAMASK_grid
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
endif
enddo; write(IO_STDOUT,'(/)',advance='no')
enddo
endif
end if
end do; write(IO_STDOUT,'(/)',advance='no')
end do
end if
if (any(dNeq(loadCases(l)%rot%asMatrix(), math_I3))) &
write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',&
transpose(loadCases(l)%rot%asMatrix())
@ -298,7 +298,7 @@ program DAMASK_grid
print'(2x,a)', 'r: 1 (constant step width)'
else
print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r
endif
end if
print'(2x,a,1x,f0.3)', 't:', loadCases(l)%t
print'(2x,a,1x,i0)', 'N:', loadCases(l)%N
if (loadCases(l)%f_out < huge(0)) &
@ -308,8 +308,8 @@ program DAMASK_grid
if (errorID > 0) call IO_error(errorID,label1='line',ID1=l)
endif reportAndCheck
enddo
end if reportAndCheck
end do
!--------------------------------------------------------------------------------------------------
! doing initialization depending on active solvers
@ -337,14 +337,14 @@ program DAMASK_grid
else writeHeader
open(newunit=statUnit,file=trim(getSolverJobName())//&
'.sta',form='FORMATTED', position='APPEND', status='OLD')
endif writeHeader
endif
end if writeHeader
end if
writeUndeformed: if (CLI_restartInc < 1) then
print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT)
call materialpoint_results(0,0.0_pReal)
endif writeUndeformed
end if writeUndeformed
loadCaseLooping: do l = 1, size(loadCases)
t_0 = t ! load case start time
@ -361,7 +361,7 @@ program DAMASK_grid
else
Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) &
/ (1.0_pReal-loadCases(l)%r**loadCases(l)%N)
endif
end if
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?
@ -402,7 +402,7 @@ program DAMASK_grid
case(FIELD_THERMAL_ID); call grid_thermal_spectral_forward(cutBack)
case(FIELD_DAMAGE_ID); call grid_damage_spectral_forward(cutBack)
end select
enddo
end do
if (.not. cutBack) call materialpoint_forward
!--------------------------------------------------------------------------------------------------
@ -422,12 +422,12 @@ program DAMASK_grid
if (.not. solres(field)%converged) exit ! no solution found
enddo
end do
stagIter = stagIter + 1
stagIterate = stagIter < stagItMax &
.and. all(solres(:)%converged) &
.and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration
enddo
end do
!--------------------------------------------------------------------------------------------------
! check solution for either advance or retry
@ -442,7 +442,7 @@ program DAMASK_grid
write(statUnit,*) totalIncsCounter, t, cutBackLevel, &
solres(1)%converged, solres(1)%iterationsNeeded
flush(statUnit)
endif
end if
elseif (cutBackLevel < maxCutBack) then ! further cutbacking tolerated?
cutBack = .true.
stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator
@ -453,9 +453,9 @@ program DAMASK_grid
else ! no more options to continue
if (worldrank == 0) close(statUnit)
call IO_error(950)
endif
end if
enddo subStepLooping
end do subStepLooping
cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc
@ -463,7 +463,7 @@ program DAMASK_grid
print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' converged'
else
print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' NOT converged'
endif; flush(IO_STDOUT)
end if; flush(IO_STDOUT)
call MPI_Allreduce(signals_SIGUSR1,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -471,7 +471,7 @@ program DAMASK_grid
print'(/,1x,a)', '... writing results to file ...............................................'
flush(IO_STDOUT)
call materialpoint_results(totalIncsCounter,t)
endif
end if
if (signal) call signals_setSIGUSR1(.false.)
call MPI_Allreduce(signals_SIGUSR2,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -485,16 +485,16 @@ program DAMASK_grid
end select
end do
call materialpoint_restartWrite
endif
end if
if (signal) call signals_setSIGUSR2(.false.)
call MPI_Allreduce(signals_SIGINT,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (signal) exit loadCaseLooping
endif skipping
end if skipping
enddo incLooping
end do incLooping
enddo loadCaseLooping
end do loadCaseLooping
!--------------------------------------------------------------------------------------------------
@ -523,9 +523,9 @@ subroutine getMaskedTensor(values,mask,tensor)
do j = 1,3
mask(i,j) = row%get_asString(j) == 'x'
if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j)
enddo
enddo
end do
end do
end subroutine
end subroutine getMaskedTensor
end program DAMASK_grid

4
src/grid/VTI.f90
View File

@ -222,7 +222,7 @@ subroutine cellsSizeOrigin(c,s,o,header)
temp = getXMLValue(header,'Origin')
o = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)]
end subroutine
end subroutine cellsSizeOrigin
!--------------------------------------------------------------------------------------------------
@ -421,7 +421,7 @@ pure function getXMLValue(line,key)
end if
end if
end function
end function getXMLValue
!--------------------------------------------------------------------------------------------------

10
src/grid/base64.f90
View File

@ -82,7 +82,7 @@ function base64_to_bytes(base64_str,s,e) result(bytes)
else
s_str = 1_pI64
s_bytes = 1_pI64
endif
end if
if(present(e)) then
if(e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range')
@ -93,7 +93,7 @@ function base64_to_bytes(base64_str,s,e) result(bytes)
e_bytes = base64_nByte(len(base64_str,kind=pI64)) - base64_nByte(s_str)
if(base64_str(e_str-0_pI64:e_str-0_pI64) == '=') e_bytes = e_bytes - 1_pI64
if(base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64
endif
end if
bytes = decodeBase64(base64_str(s_str:e_str))
bytes = bytes(s_bytes:e_bytes)
@ -122,8 +122,8 @@ pure function decodeBase64(base64_str) result(bytes)
charPos(p) = int(index(base64_encoding,base64_str(c+p:c+p))-1,C_SIGNED_CHAR)
else
charPos(p) = 0_C_SIGNED_CHAR
endif
enddo
end if
end do
call mvbits(charPos(0),0,6,bytes(b+0),2)
call mvbits(charPos(1),4,2,bytes(b+0),0)
@ -133,7 +133,7 @@ pure function decodeBase64(base64_str) result(bytes)
call mvbits(charPos(3),0,6,bytes(b+2),0)
b = b+3_pI64
c = c+4_pI64
enddo
end do
end function decodeBase64

2
src/grid/discretization_grid.f90
View File

@ -334,7 +334,7 @@ function discretization_grid_getInitialCondition(label) result(ic)
ic_global = VTI_readDataset_real(IO_read(CLI_geomFile),label)
else
allocate(ic_global(0)) ! needed for IntelMPI
endif
end if
call MPI_Gather(product(cells(1:2))*cells3Offset, 1_MPI_INTEGER_KIND,MPI_INTEGER,displs,&
1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)

32
src/grid/grid_mech_FEM.f90
View File

@ -274,7 +274,7 @@ subroutine grid_mechanical_FEM_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 = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3)
endif restartRead
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(F)
@ -298,7 +298,7 @@ subroutine grid_mechanical_FEM_init
call HDF5_closeGroup(groupHandle)
call HDF5_closeFile(fileHandle)
endif restartRead2
end if restartRead2
end subroutine grid_mechanical_FEM_init
@ -387,7 +387,7 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai
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)
endif
end if
if (guess) then
call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,err_PETSc)
@ -397,14 +397,14 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai
else
call VecSet(solution_rate,0.0_pReal,err_PETSc)
CHKERRQ(err_PETSc)
endif
end if
call VecCopy(solution_current,solution_lastInc,err_PETSc)
CHKERRQ(err_PETSc)
F_lastInc = F
homogenization_F0 = reshape(F, [3,3,product(cells(1:2))*cells3])
endif
end if
!--------------------------------------------------------------------------------------------------
! update average and local deformation gradients
@ -477,7 +477,7 @@ subroutine grid_mechanical_FEM_restartWrite
call HDF5_write(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.)
call HDF5_closeGroup(groupHandle)
call HDF5_closeFile(fileHandle)
endif
end if
call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(err_PETSc)
@ -517,7 +517,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e
reason = -1
else
reason = 0
endif
end if
print'(/,1x,a)', '... reporting .............................................................'
print'(/,1x,a,f12.2,a,es8.2,a,es9.2,a)', 'error divergence = ', &
@ -567,7 +567,7 @@ subroutine formResidual(da_local,x_local, &
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
'deformation gradient aim =', transpose(F_aim)
flush(IO_STDOUT)
endif newIteration
end if newIteration
!--------------------------------------------------------------------------------------------------
! get deformation gradient
@ -578,9 +578,9 @@ subroutine formResidual(da_local,x_local, &
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1
x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk)
enddo; enddo; enddo
end do; end do; end do
F(1:3,1:3,i,j,k-cells3Offset) = params%rotation_BC%rotate(F_aim,active=.true.) + transpose(matmul(BMat,x_elem))
enddo; enddo; enddo
end do; end do; end do
call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
@ -611,7 +611,7 @@ subroutine formResidual(da_local,x_local, &
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1
x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk)
enddo; enddo; enddo
end do; end do; end do
ele = ele + 1
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) + &
@ -621,8 +621,8 @@ subroutine formResidual(da_local,x_local, &
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1
r(0:2,i+ii,j+jj,k+kk) = r(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3)
enddo; enddo; enddo
enddo; enddo; enddo
end do; end do; end do
end do; end do; end do
call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc)
@ -696,7 +696,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
col(MatStencil_j,ctr+16) = j+jj
col(MatStencil_k,ctr+16) = k+kk
col(MatStencil_c,ctr+16) = 2
enddo; enddo; enddo
end do; end do; end do
row = col
ce = ce + 1
K_ele = 0.0_pReal
@ -715,7 +715,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ
call MatSetValuesStencil(Jac,24_pPETScInt,row,24_pPetscInt,col,K_ele,ADD_VALUES,err_PETSc)
CHKERRQ(err_PETSc)
enddo; enddo; enddo
end do; end do; end do
call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
CHKERRQ(err_PETSc)
call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
@ -739,7 +739,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1)
ce = ce + 1
x_scal(0:2,i-1,j-1,k-1) = discretization_IPcoords(1:3,ce)
enddo; enddo; enddo
end do; end do; end do
call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,err_PETSc)
CHKERRQ(err_PETSc) ! initialize to undeformed coordinates (ToDo: use ip coordinates)
call MatNullSpaceCreateRigidBody(coordinates,matnull,err_PETSc)

2
src/materialpoint.f90
View File

@ -95,7 +95,7 @@ subroutine materialpoint_init
call phase_restartRead(fileHandle)
call HDF5_closeFile(fileHandle)
endif
end if
end subroutine materialpoint_init

2
src/mesh/DAMASK_mesh.f90
View File

@ -311,7 +311,7 @@ program DAMASK_mesh
write(statUnit,*) totalIncsCounter, time, cutBackLevel, &
solres%converged, solres%iterationsNeeded ! write statistics about accepted solution
flush(statUnit)
endif
end if
end do subStepLooping
cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc

8
src/mesh/FEM_quadrature.f90
View File

@ -365,16 +365,16 @@ subroutine selfTest
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)) &
error stop 'quadrature weights'
enddo
enddo
end do
end do
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))) &
error stop 'quadrature points'
enddo
enddo
end do
end do
end subroutine selfTest

16
src/mesh/discretization_mesh.f90
View File

@ -140,7 +140,7 @@ subroutine discretization_mesh_init(restart)
call DMClone(globalMesh,geomMesh,err_PETSc)
else
call DMPlexDistribute(globalMesh,0_pPETSCINT,sf,geomMesh,err_PETSc)
endif
end if
CHKERRQ(err_PETSc)
allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pPETSCINT)
@ -154,7 +154,7 @@ subroutine discretization_mesh_init(restart)
mesh_boundaries(1:nFaceSets) = pFaceSets
CHKERRQ(err_PETSc)
call ISRestoreIndicesF90(faceSetIS,pFaceSets,err_PETSc)
endif
end if
call MPI_Bcast(mesh_boundaries,mesh_Nboundaries,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -182,7 +182,7 @@ subroutine discretization_mesh_init(restart)
do j = 1, mesh_NcpElems
call DMGetLabelValue(geomMesh,'Cell Sets',j-1,materialAt(j),err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
materialAt = materialAt + 1_pPETSCINT
if (debug_element < 1 .or. debug_element > mesh_NcpElems) call IO_error(602,ext_msg='element')
@ -222,7 +222,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex)
call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc)
CHKERRQ(err_PETSc)
mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal)
enddo
end do
end subroutine mesh_FEM_build_ipVolumes
@ -258,11 +258,11 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
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)
enddo
enddo
end do
end do
qOffset = qOffset + dimPlex
enddo
enddo
end do
end do
end subroutine mesh_FEM_build_ipCoordinates

78
src/mesh/mesh_mech_FEM.f90
View File

@ -199,11 +199,11 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc)
call PetscSectionGetDof(section,cellStart,pnumDof(topologDim),err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
numBC = 0
do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries
if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1
enddo; enddo
end do; end do
allocate(pbcField(numBC), source=0_pPETSCINT)
allocate(pbcComps(numBC))
allocate(pbcPoints(numBC))
@ -229,9 +229,9 @@ subroutine FEM_mechanical_init(fieldBC)
else
call ISCreateGeneral(PETSC_COMM_WORLD,0_pPETSCINT,[0_pPETSCINT],PETSC_COPY_VALUES,pbcPoints(numBC),err_PETSc)
CHKERRQ(err_PETSc)
endif
endif
enddo; enddo
end if
end if
end do; end do
call DMPlexCreateSection(mechanical_mesh,nolabel,pNumComp,pNumDof, &
numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS,section,err_PETSc)
CHKERRQ(err_PETSc)
@ -240,7 +240,7 @@ subroutine FEM_mechanical_init(fieldBC)
do faceSet = 1, numBC
call ISDestroy(pbcPoints(faceSet),err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
!--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc
@ -299,11 +299,11 @@ subroutine FEM_mechanical_init(fieldBC)
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)
enddo
end do
px_scal => x_scal
call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
call utilities_constitutiveResponse(0.0_pReal,devNull,.true.)
end subroutine FEM_mechanical_init
@ -348,7 +348,7 @@ type(tSolutionState) function FEM_mechanical_solution( &
FEM_mechanical_solution%converged = .true.
call SNESGetIterationNumber(mechanical_snes,FEM_mechanical_solution%iterationsNeeded,err_PETSc)
CHKERRQ(err_PETSc)
endif
end if
print'(/,1x,a)', '==========================================================================='
flush(IO_STDOUT)
@ -409,9 +409,9 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc)
endif
endif
enddo; enddo
end if
end if
end do; end do
!--------------------------------------------------------------------------------------------------
! evaluate field derivatives
@ -433,10 +433,10 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
end do
end do
homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1])
enddo
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))
do qPt = 0, nQuadrature-1
@ -444,11 +444,11 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
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))
enddo
endif
end do
end if
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
!--------------------------------------------------------------------------------------------------
! evaluate constitutive response
@ -475,20 +475,20 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
end do
end do
f_scal = f_scal &
+ matmul(transpose(BMat), &
reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), &
shape=[dimPlex*dimPlex]))*qWeights(qPt+1_pPETSCINT)
enddo
end do
f_scal = f_scal*abs(detJ)
pf_scal => f_scal
call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,err_PETSc)
CHKERRQ(err_PETSc)
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
call DMRestoreLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc)
@ -559,9 +559,9 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc)
endif
endif
enddo; enddo
end if
end if
end do; end do
call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
CHKERRQ(err_PETSc)
do cell = cellStart, cellEnd-1 !< loop over all elements
@ -583,8 +583,8 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(reshape(pInvcellJ,[dimPlex,dimPlex]),basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
end do
end do
MatA = matmul(reshape(reshape(homogenization_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,m), &
shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), &
shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1_pPETSCINT)
@ -602,8 +602,8 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
BMatAvg = BMatAvg + BMat
else
K_eA = K_eA + matmul(transpose(BMat),MatA)
endif
enddo
end if
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)) + &
@ -612,7 +612,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
K_eB)/real(dimPlex,pReal)
else
K_e = K_eA
endif
end if
K_e = (K_e + eps*math_eye(int(cellDof))) * abs(detJ)
#ifndef __INTEL_COMPILER
pK_e(1:cellDOF**2) => K_e
@ -624,7 +624,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
CHKERRQ(err_PETSc)
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
enddo
end do
call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
CHKERRQ(err_PETSc)
call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
@ -704,9 +704,9 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
0.0_pReal,fieldBC%componentBC(field)%Value(face),timeinc_old)
call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc)
endif
endif
enddo; enddo
end if
end if
end do; end do
call DMRestoreLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc)
@ -716,7 +716,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
CHKERRQ(err_PETSc)
call VecScale(solution_rate,timeinc_old**(-1),err_PETSc)
CHKERRQ(err_PETSc)
endif
end if
call VecCopy(solution_rate,solution,err_PETSc)
CHKERRQ(err_PETSc)
call VecScale(solution,timeinc,err_PETSc)
@ -800,7 +800,7 @@ subroutine FEM_mechanical_updateCoords()
call DMPlexGetPointLocal(dm_local, p, s, e, err_PETSc)
CHKERRQ(err_PETSc)
nodeCoords(1:dimPlex,p)=nodeCoords_linear(s+1:e)
enddo
end do
call discretization_setNodeCoords(nodeCoords)
call VecRestoreArrayF90(x_local,nodeCoords_linear,err_PETSc)
@ -827,9 +827,9 @@ subroutine FEM_mechanical_updateCoords()
x_scal(nOffset+1:nOffset+dimPlex))
q = q+dimPlex
nOffset = nOffset+dimPlex
enddo
enddo
enddo
end do
end do
end do
call DMPlexVecRestoreClosure(dm_local,section,x_local,c,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
end do

2
src/phase_mechanical_plastic_nonlocal.f90
View File

@ -1783,6 +1783,6 @@ subroutine storeGeometry(ph)
end do
end do
end subroutine
end subroutine storeGeometry
end submodule nonlocal