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

This commit is contained in:
Christoph Kords 2009-10-19 07:56:47 +00:00
parent 992077e88e
commit ba02dfca1e
41 changed files with 37557 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
patch/material.config Normal file
View File

@ -0,0 +1,84 @@
<homogenization>
[Taylor]
type Taylor
Ngrains 1
<microstructure>
[j2]
(constituent) phase 1 texture 1 fraction 1.0
[grain2]
(constituent) phase 2 texture 2 fraction 1.0
[grain5]
(constituent) phase 2 texture 3 fraction 1.0
[grain4]
(constituent) phase 2 texture 4 fraction 1.0
[grain1]
(constituent) phase 2 texture 5 fraction 1.0
[grain6]
(constituent) phase 2 texture 6 fraction 1.0
[grain3]
(constituent) phase 2 texture 7 fraction 1.0
<phase>
[phase1]
constitution j2
(output) flowstress
c11 110.9e9
c12 58.34e9
taylorfactor 3
s0 31e6
gdot0 0.001
n 20
h0 75e6
s_sat 63e6
w0 2.25
[phase2]
constitution phenomenological
(output) slipResistance
(output) rateofshear
lattice_structure fcc
Nslip 12
c11 106.75e9
c12 60.41e9
c44 28.34e9
s0_slip 31e6
gdot0_slip 0.001
n_slip 20
h0 75e6
s_sat 63e6
w0 2.25
# Self and latent hardening coefficients
hardening_coefficients 1.0 1.4
<texture>
[random]
[grain 2]
(gauss) phi1 0.687549 Phi 44.518821 phi2 33.288848 scatter 0.0 fraction 1.0
[grain 5]
(gauss) phi1 268.946389 Phi 21.772396 phi2 71.390541 scatter 0.0 fraction 1.0
[grain 4]
(gauss) phi1 109.434939 Phi 41.654032 phi2 280.290953 scatter 0.0 fraction 1.0
[grain 1]
(gauss) phi1 51.566202 Phi 46.581469 phi2 288.713433 scatter 0.0 fraction 1.0
[grain 6]
(gauss) phi1 189.820918 Phi 37.356848 phi2 177.788804 scatter 0.0 fraction 1.0
[grain 3]
(gauss) phi1 233.365710 Phi 40.278933 phi2 170.913310 scatter 0.0 fraction 1.0

839
patch/patchSquare Normal file
View File

@ -0,0 +1,839 @@
#!/usr/bin/env python
import sys,os,pwd,math,re
#import Image,ImageDraw
try:
if os.path.exists('/msc/mentat2008r1/shlib'):
sys.path.append("/msc/mentat2008r1/shlib")
else:
sys.path.append("/msc/mentat2007r1/shlib")
except:
sys.exit(-1)
from py_mentat import *
from optparse import OptionParser
def outMentat(cmd,locals):
if cmd[0:3] == '(!)':
exec(cmd[3:])
elif cmd[0:3] == '(?)':
cmd = eval(cmd[3:])
py_send(cmd)
else:
py_send(cmd)
return
def outStdout(cmd,locals):
if cmd[0:3] == '(!)':
exec(cmd[3:])
elif cmd[0:3] == '(?)':
cmd = eval(cmd[3:])
print cmd
else:
print cmd
return
def output(cmds,locals,dest):
for cmd in cmds:
if isinstance(cmd,list):
output(cmd,locals,dest)
else:
{\
'Mentat': outMentat,\
'Stdout': outStdout,\
}[dest](cmd,locals)
return
def rcbOrientationParser(content):
grains = []
myOrientation = [0.0,0.0,0.0]
for line in content:
if line[0] != '#': # skip comments
for grain in range(2):
myID = int(line.split()[12+grain]) # get grain id
myOrientation = map(float,line.split())[3*grain:3+3*grain] # get orientation
if len(grains) < myID:
for i in range(myID-len(grains)): # extend list to necessary length
grains.append([0.0,0.0,0.0])
grains[myID-1] = myOrientation # store Euler angles
return grains
def rcbParser(content,size,tolerance,imagename,imagesize,border): # parser for TSL-OIM reconstructed boundary files
# find bounding box
boxX = [1.*sys.maxint,-1.*sys.maxint]
boxY = [1.*sys.maxint,-1.*sys.maxint]
x = [0.,0.]
y = [0.,0.]
for line in content:
if line[0] != '#': # skip comments
(x[0],y[0],x[1],y[1]) = map(float,line.split())[8:12] # get start and end coordinates of each segment
boxX[0] = min(boxX[0],x[0],x[1])
boxX[1] = max(boxX[1],x[0],x[1])
boxY[0] = min(boxY[0],y[0],y[1])
boxY[1] = max(boxY[1],y[0],y[1])
scaleImg = imagesize/max(boxX[1]-boxX[0],boxY[1]-boxY[0])
scalePatch = size/(boxY[1]-boxY[0])
if scaleImg > 0: # create image
img = Image.new("RGB",map(lambda x:int(round(x))+border*2,(scaleImg*(boxX[1]-boxX[0]),scaleImg*(boxY[1]-boxY[0]))),(255,255,255))
draw = ImageDraw.Draw(img)
# read segments and draw them
segment = 0
connectivityXY = {"0": {"0":[],"%g"%(boxY[1]-boxY[0]):[],},\
"%g"%(boxX[1]-boxX[0]): {"0":[],"%g"%(boxY[1]-boxY[0]):[],},}
connectivityYX = {"0": {"0":[],"%g"%(boxX[1]-boxX[0]):[],},\
"%g"%(boxY[1]-boxY[0]): {"0":[],"%g"%(boxX[1]-boxX[0]):[],},}
grainNeighbors = []
for line in content:
if line[0] != '#': # skip comments
(x[0],y[0],x[1],y[1]) = map(float,line.split())[8:12] # get start and end coordinates of each segment
# make relative to origin of bounding box
x[0]=boxX[1]-x[0]
x[1]=boxX[1]-x[1]
y[0]=boxY[1]-y[0]
y[1]=boxY[1]-y[1]
grainNeighbors.append(map(int,line.split()[12:14])) # remember right and left grain per segment
for i in range(2): # store segment to both points
# check whether point is already known (within a small range)
match = False
for posX in connectivityXY.keys():
if (abs(float(posX)-x[i])<(boxX[1]-boxX[0])*tolerance):
for posY in connectivityXY[posX].keys():
if (abs(float(posY)-y[i])<(boxY[1]-boxY[0])*tolerance):
keyX = posX
keyY = posY
break
break
if (not match):
# force to boundary if inside tolerance to it
if (abs(x[i])<(boxX[1]-boxX[0])*options.tolerance):
x[i] = 0
if (abs(boxX[1]-boxX[0]-x[i])<(boxX[1]-boxX[0])*tolerance):
x[i] = boxX[1]-boxX[0]
if (abs(y[i])<(boxY[1]-boxY[0])*tolerance):
y[i] = 0
if (abs(boxY[1]-boxY[0]-y[i])<(boxY[1]-boxY[0])*tolerance):
y[i] = boxY[1]-boxY[0]
keyX = "%g"%x[i]
keyY = "%g"%y[i]
if keyX not in connectivityXY: # create new hash entry for so far unknown point
connectivityXY[keyX] = {}
if keyY not in connectivityXY[keyX]: # create new hash entry for so far unknown point
connectivityXY[keyX][keyY] = []
if keyY not in connectivityYX: # create new hash entry for so far unknown point
connectivityYX[keyY] = {}
if keyX not in connectivityYX[keyY]: # create new hash entry for so far unknown point
connectivityYX[keyY][keyX] = []
connectivityXY[keyX][keyY].append(segment)
connectivityYX[keyY][keyX].append(segment)
if scaleImg > 0:
draw.line(map(lambda x:int(scaleImg*x)+border,[x[0],y[0],x[1],y[1]]),fill=(128,128,128))
draw.text(map(lambda x:int(scaleImg*x)+border,[(x[1]+x[0])/2.0,(y[1]+y[0])/2.0]),"%i"%segment,fill=(0,0,128))
segment += 1
# top border
keyId = "0"
boundary = connectivityYX[keyId].keys()
boundary.sort(key=float)
for indexBdy in range(len(boundary)-1):
connectivityXY[boundary[indexBdy]][keyId].append(segment)
connectivityXY[boundary[indexBdy+1]][keyId].append(segment)
connectivityYX[keyId][boundary[indexBdy]].append(segment)
connectivityYX[keyId][boundary[indexBdy+1]].append(segment)
if scaleImg > 0:
draw.line(map(lambda x:int(scaleImg*x)+border,[float(boundary[indexBdy]),float(keyId),float(boundary[indexBdy+1]),float(keyId)]),width=3,fill=(128,128*(segment%2),0))
draw.text(map(lambda x:int(scaleImg*x)+border,[(float(boundary[indexBdy])+float(boundary[indexBdy+1]))/2.0,float(keyId)]),"%i"%segment,fill=(0,0,128))
segment += 1
# right border
keyId = "%g"%(boxX[1]-boxX[0])
boundary = connectivityXY[keyId].keys()
boundary.sort(key=float)
for indexBdy in range(len(boundary)-1):
connectivityYX[boundary[indexBdy]][keyId].append(segment)
connectivityYX[boundary[indexBdy+1]][keyId].append(segment)
connectivityXY[keyId][boundary[indexBdy]].append(segment)
connectivityXY[keyId][boundary[indexBdy+1]].append(segment)
if scaleImg > 0:
draw.line(map(lambda x:int(scaleImg*x)+border,[float(keyId),float(boundary[indexBdy]),float(keyId),float(boundary[indexBdy+1])]),width=3,fill=(128,128*(segment%2),0))
draw.text(map(lambda x:int(scaleImg*x)+border,[float(keyId),(float(boundary[indexBdy])+float(boundary[indexBdy+1]))/2.0]),"%i"%segment,fill=(0,0,128))
segment += 1
# bottom border
keyId = "%g"%(boxY[1]-boxY[0])
boundary = connectivityYX[keyId].keys()
boundary.sort(key=float,reverse=True)
for indexBdy in range(len(boundary)-1):
connectivityXY[boundary[indexBdy]][keyId].append(segment)
connectivityXY[boundary[indexBdy+1]][keyId].append(segment)
connectivityYX[keyId][boundary[indexBdy]].append(segment)
connectivityYX[keyId][boundary[indexBdy+1]].append(segment)
if scaleImg > 0:
draw.line(map(lambda x:int(scaleImg*x)+border,[float(boundary[indexBdy]),float(keyId),float(boundary[indexBdy+1]),float(keyId)]),width=3,fill=(128,128*(segment%2),0))
draw.text(map(lambda x:int(scaleImg*x)+border,[(float(boundary[indexBdy])+float(boundary[indexBdy+1]))/2.0,float(keyId)]),"%i"%segment,fill=(0,0,128))
segment += 1
# left border
keyId = "0"
boundary = connectivityXY[keyId].keys()
boundary.sort(key=float,reverse=True)
for indexBdy in range(len(boundary)-1):
connectivityYX[boundary[indexBdy]][keyId].append(segment)
connectivityYX[boundary[indexBdy+1]][keyId].append(segment)
connectivityXY[keyId][boundary[indexBdy]].append(segment)
connectivityXY[keyId][boundary[indexBdy+1]].append(segment)
if scaleImg > 0:
draw.line(map(lambda x:int(scaleImg*x)+border,[float(keyId),float(boundary[indexBdy]),float(keyId),float(boundary[indexBdy+1])]),width=3,fill=(128,128*(segment%2),0))
draw.text(map(lambda x:int(scaleImg*x)+border,[float(keyId),(float(boundary[indexBdy])+float(boundary[indexBdy+1]))/2.0]),"%i"%segment,fill=(0,0,128))
segment += 1
allkeysX = connectivityXY.keys()
allkeysX.sort()
points = []
segments = [[] for i in range(segment)]
pointId = 0
for keyX in allkeysX:
allkeysY = connectivityXY[keyX].keys()
allkeysY.sort()
for keyY in allkeysY:
points.append({'coords': [float(keyX)*scalePatch,float(keyY)*scalePatch], 'segments': connectivityXY[keyX][keyY]})
for segment in connectivityXY[keyX][keyY]:
if (segments[segment] == None):
segments[segment] = pointId
else:
segments[segment].append(pointId)
if scaleImg > 0:
draw.text(map(lambda x:int(scaleImg*x)+border,[float(keyX),float(keyY)]),"%i"%pointId,fill=(0,0,0))
pointId += 1
if scaleImg > 0:
img.save(imagename+'.png',"PNG")
grains = {'draw': [], 'legs': []}
pointId = 0
for point in points:
while point['segments']:
myStart = pointId
grainDraw = [points[myStart]['coords']]
innerAngleSum = 0.0
myWalk = point['segments'].pop()
grainLegs = [myWalk]
if segments[myWalk][0] == myStart:
myEnd = segments[myWalk][1]
else:
myEnd = segments[myWalk][0]
while (myEnd != pointId):
myV = [points[myEnd]['coords'][0]-points[myStart]['coords'][0],\
points[myEnd]['coords'][1]-points[myStart]['coords'][1]]
myLen = math.sqrt(myV[0]**2+myV[1]**2)
best = {'product': -2.0, 'peek': -1, 'len': -1, 'point': -1}
for peek in points[myEnd]['segments']:
if peek == myWalk:
continue
if segments[peek][0] == myEnd:
peekEnd = segments[peek][1]
else:
peekEnd = segments[peek][0]
peekV = [points[myEnd]['coords'][0]-points[peekEnd]['coords'][0],\
points[myEnd]['coords'][1]-points[peekEnd]['coords'][1]]
peekLen = math.sqrt(peekV[0]**2+peekV[1]**2)
crossproduct = (myV[0]*peekV[1]-myV[1]*peekV[0])/myLen/peekLen
dotproduct = (myV[0]*peekV[0]+myV[1]*peekV[1])/myLen/peekLen
if crossproduct*(dotproduct+1.0) >= best['product']:
best['product'] = crossproduct*(dotproduct+1.0)
best['peek'] = peek
best['point'] = peekEnd
innerAngleSum += best['product']
myWalk = best['peek']
myStart = myEnd
myEnd = best['point']
points[myStart]['segments'].remove(myWalk)
grainDraw.append(points[myStart]['coords'])
grainLegs.append(myWalk)
if innerAngleSum > 0.0:
grains['draw'].append(grainDraw)
grains['legs'].append(grainLegs)
else:
grains['box'] = grainLegs
pointId += 1
# build overall data structure
rcData = {'dimension':[boxX[1]-boxX[0],boxY[1]-boxY[0]], 'point': [],'segment': [], 'grain': [], 'grainMapping': []}
for point in points:
rcData['point'].append(point['coords'])
print "found %i points"%(len(rcData['point']))
for segment in segments:
rcData['segment'].append(segment)
print "built %i segments"%(len(rcData['segment']))
for grain in grains['legs']:
rcData['grain'].append(grain)
myNeighbors = {}
for leg in grain:
if leg < len(grainNeighbors):
for side in range(2):
if grainNeighbors[leg][side] in myNeighbors:
myNeighbors[grainNeighbors[leg][side]] += 1
else:
myNeighbors[grainNeighbors[leg][side]] = 1
if myNeighbors: # do I have any neighbors
rcData['grainMapping'].append(sorted(myNeighbors.iteritems(), key=lambda (k,v): (v,k), reverse=True)[0][0]) # most frequent grain is me
print "found %i grains"%(len(rcData['grain']))
rcData['box'] = grains['box']
if scaleImg > 0:
grainID = 0
for grain in grains['draw']:
coords = [0,0]
for point in grain:
coords[0] += int(scaleImg/scalePatch*point[0])
coords[1] += int(scaleImg/scalePatch*point[1])
coords[0] /= len(grain)
coords[1] /= len(grain)
draw.text(map(lambda x:x+border,coords),'%i -> %i'%(grainID,rcData['grainMapping'][grainID]),fill=(128,32,32))
grainID += 1
img.save(os.path.splitext(args[0])[0]+'.png',"PNG")
return rcData
def init():
return ["*new_model yes",
"*select_clear",
"*reset",
"*set_nodes off",
"*elements_solid",
"*show_view 4",
"*reset_view",
"*view_perspective",
"*redraw",
]
def sample(a,n,margin):
cmds = [\
# gauge
"*add_points %f %f %f"%(-(margin[0]+0.5)*a, (margin[1]+0.5)*a,0),
"*add_points %f %f %f"%( (margin[0]+0.5)*a, (margin[1]+0.5)*a,0),
"*add_points %f %f %f"%( (margin[0]+0.5)*a,-(margin[1]+0.5)*a,0),
"*add_points %f %f %f"%(-(margin[0]+0.5)*a,-(margin[1]+0.5)*a,0),
"*set_curve_type line",
"*add_curves %i %i"%(1,2),
"*add_curves %i %i"%(3,4),
"*set_curve_div_type_fix_ndiv",
"*set_curve_div_num %i"%n,
"*apply_curve_divisions",
"1 2 #",
"*add_curves %i %i"%(2,3), # right side
"*add_curves %i %i"%(4,1), # left side
"*set_curve_div_type_fix_ndiv",
"*set_curve_div_num %i"%n,
"*apply_curve_divisions",
"3 4 #",
]
return cmds
def patch(a,n,mesh,rcData):
cmds = []
for l in range(len(rcData['point'])): # generate all points
# cmds.append("*add_points %f %f %f"%(rcData['point'][l][1]-a/2.0, rcData['point'][l][0]-a*rcData['dimension'][0]/rcData['dimension'][1]/2.0, 0))
cmds.append("*add_points %f %f %f"%(rcData['point'][l][0]-a*rcData['dimension'][0]/rcData['dimension'][1]/2.0, rcData['point'][l][1]-a/2.0, 0))
cmds.append(["*set_curve_type line",
"*set_curve_div_type_fix_ndiv",
])
for m in range(len(rcData['segment'])): # generate all curves and subdivide them for overall balanced piece length
start = rcData['segment'][m][0]
end = rcData['segment'][m][1]
cmds.append([\
"*add_curves %i %i" %(start+rcData['offsetPoints'],
end +rcData['offsetPoints']),
"*set_curve_div_num %i"%(max(1,round(math.sqrt((rcData['point'][start][0]-rcData['point'][end][0])**2+\
(rcData['point'][start][1]-rcData['point'][end][1])**2)/a*n))),
"*apply_curve_divisions",
"%i #"%(m+rcData['offsetSegments']),
])
grain = 0
cmds.append('(!)locals["last"] = py_get_int("nelements()")')
"*set_mesh_transition 1.0",
for g in rcData['grain']:
cmds.append([\
'(!)locals["first"] = locals["last"]+1',
"*%s "%mesh+" ".join([str(rcData['offsetSegments']+x) for x in g])+" #",
'(!)locals["last"] = py_get_int("nelements()")',
"*select_elements",
'(?)"%i to %i #"%(locals["first"],locals["last"])',
"*store_elements grain_%i"%rcData['grainMapping'][grain],
"all_selected",
"*select_clear",
])
grain += 1
return cmds
def gage(mesh,rcData):
return([\
"*set_mesh_transition 1.0",
"*%s "%mesh +
" ".join([str(x) for x in range(1,rcData['offsetSegments'])]) +
" " +
" ".join([str(rcData['offsetSegments']+x)for x in rcData['box']]) +
" #",
"*select_reset",
"*select_clear",
"*select_elements",
"all_existing",
"*select_mode_except",
['grain_%i'%(i+1) for i in range(len(rcData['grain']))],
"#",
"*store_elements matrix",
"all_selected",
"*select_mode_invert",
"*select_elements",
"all_existing",
"*store_elements grains",
"all_selected",
"*select_clear",
"*select_reset",
])
def expand3D(thickness,steps):
return([\
"*set_expand_translation z %f"%(thickness/steps),
"*set_expand_repetitions %i"%steps,
"*expand_elements",
"all_existing",
])
def initial_conditions(grainNumber,grainMapping):
cmds = [\
"*new_icond",
"*icond_name taylor",
"*icond_type state_variable",
"*icond_param_value state_var_id 2",
"*icond_dof_value var 1",
"*add_icond_elements",
"grains",
"*add_icond_elements",
"matrix",
"*new_icond",
"*icond_name j2",
"*icond_type state_variable",
"*icond_param_value state_var_id 3",
"*icond_dof_value var 1",
"*add_icond_elements",
"matrix",
]
for grain in range(grainNumber):
cmds.append([\
"*new_icond",
"*icond_name grain%i_texture%i"%(grainMapping[grain],(grain+2)),
"*icond_type state_variable",
"*icond_param_value state_var_id 3",
"*icond_dof_value var %i"%(grain+2),
"*add_icond_elements",
"grain_%i"%grainMapping[grain],
"",])
return cmds
def boundary_conditions(rate,thickness, a, margin):
inner = ((margin[0]+0.5) - 1.0e-4) * a
outer = ((margin[0]+0.5) + 1.0e-4) * a
upper = ((margin[1]+0.5) + 1.0e-4) * a
lower = ((margin[1]+0.5) - 1.0e-4) * a
return [\
"*new_md_table 1 1",
"*table_name linear",
"*set_md_table_type 1 time",
"*table_add",
"0 0",
"1 1",
"*select_method_box",
"*new_apply",
"*apply_name pull_bottom",
"*apply_type fixed_displacement",
"*apply_dof y",
"*apply_dof_value y %f"%(-rate*(inner+outer)/2.0),
"*apply_dof_table y linear",
"*select_clear_nodes",
"*select_nodes",
"%f %f"%(-outer,outer),
"%f %f"%(-upper,-lower),
"%f %f"%(-.0001*a,(thickness+1.0e-4)*a),
"*add_apply_nodes",
"all_selected",
"*new_apply",
"*apply_name pull_top",
"*apply_type fixed_displacement",
"*apply_dof y",
"*apply_dof_value y %f"%(rate*(inner+outer)/2.0),
"*apply_dof_table y linear",
"*select_clear_nodes",
"*select_nodes",
"%f %f"%(-outer,outer),
"%f %f"%(lower,upper),
"%f %f"%(-.0001*a,(thickness+1.0e-4)*a),
"*add_apply_nodes",
"all_selected",
"*new_apply",
"*apply_name fix_x",
"*apply_type fixed_displacement",
"*apply_dof x",
"*apply_dof_value x 0",
"*select_clear_nodes",
"*select_nodes",
"%f %f"%(-outer,-inner),
"%f %f"%(lower,upper),
"%f %f"%(-.0001*a,.0001*a),
"%f %f"%(-outer,-inner),
"%f %f"%(lower,upper),
"%f %f"%((thickness-1.0e-4)*a,(thickness+1.0e-4)*a),
"%f %f"%(-outer,-inner),
"%f %f"%(-upper,-lower),
"%f %f"%(-.0001*a,.0001*a),
"%f %f"%(-outer,-inner),
"%f %f"%(-upper,-lower),
"%f %f"%((thickness-1.0e-4)*a,(thickness+1.0e-4)*a),
"*add_apply_nodes",
"all_selected",
"*new_apply",
"*apply_name fix_z",
"*apply_type fixed_displacement",
"*apply_dof z",
"*apply_dof_value z 0",
"*select_clear_nodes",
"*select_nodes",
"%f %f"%(-outer,-inner),
"%f %f"%(lower,upper),
"%f %f"%(-.0001*a,.0001*a),
"%f %f"%(-outer,-inner),
"%f %f"%(-upper,-lower),
"%f %f"%(-.0001*a,.0001*a),
"%f %f"%(inner,outer),
"%f %f"%(lower,upper),
"%f %f"%(-.0001*a,.0001*a),
"%f %f"%(inner,outer),
"%f %f"%(-upper,-lower),
"%f %f"%(-.0001*a,.0001*a),
"*add_apply_nodes",
"all_selected",
"*select_clear",
"*select_reset",
]
def materialProperties():
return [\
"*new_material",
"*material_name hypela2",
"*material_type mechanical:hypoelastic",
"*material_option hypoelastic:method:hypela2",
"*material_option hypoelastic:pass:def_rot",
"*add_material_elements",
"all_existing",
]
def loadcase(time,incs,Ftol):
return [\
"*new_loadcase",
"*loadcase_name puller",
"*loadcase_type static",
"*loadcase_value time",
"%g"%time,
"*loadcase_value nsteps",
"%i"%incs,
"*loadcase_value maxrec",
"20",
"*loadcase_value ntime_cuts",
"30",
"*loadcase_value force",
"%g"%Ftol,
]
def job(grainNumber,grainMapping,subroutine,domains):
solver_nonsym = 'on'
if domains > 1:
solver_nonsym = 'off'
return[\
"*new_job",
"*job_name pull",
"*job_class mechanical",
"*add_job_loadcases puller",
"*add_job_iconds taylor",
"*add_job_iconds j2",
["*add_job_iconds grain%i_texture%i"%(grainMapping[i],i+2) for i in range(grainNumber)],
"*job_option dimen:three | 3D analysis",
"*job_option strain:large | finite strains",
"*job_option large_strn_proc:upd_lagrange | updated Lagrange framework",
"*job_option plas_proc:multiplicative | multiplicative decomp of F",
"*job_option solver_nonsym:%s | nonsymmetrical solution"%solver_nonsym,
"*job_option solver:mfront_sparse | multi-frontal sparse",
"*job_param stef_boltz 5.670400e-8",
"*job_param univ_gas_const 8.314472",
"*job_param planck_radiation_2 1.4387752e-2",
"*job_param speed_light_vacuum 299792458",
"*job_usersub_file %s | subroutine definition" %subroutine,
"*job_option user_source:compile_save",
"*domains_auto_decompose",
"%i"%domains,
"*job_option parallel:on",
"*job_option parallel_setup:single",
"*job_option ddm_single_post:on",
]
def postprocess():
return [\
"*add_post_tensor stress",
"*add_post_tensor strain",
"*add_post_var von_mises",
"*add_post_var user1",
"*edit_post_var user1", "phase",
"*add_post_var user2",
"*edit_post_var user2", "volFrac",
"*add_post_var user3",
"*edit_post_var user3", "phi1",
"*add_post_var user4",
"*edit_post_var user4", "Phi",
"*add_post_var user5",
"*edit_post_var user5", "phi2",
"*add_post_var user6",
"*edit_post_var user6", "slipResistance",
"*add_post_var user7",
"*edit_post_var user7", "rateofshear",
"",
]
def cleanUp(a):
return [\
"*remove_curves",
"all_existing",
"*remove_points",
"all_existing",
"*set_sweep_tolerance %f"%(1e-3*a),
"*sweep_all",
"*renumber_all",
]
def geometricProperties():
return [\
'*new_geometry',
'*geometry_name constantDilatation',
'*geometry_type mech_three_solid',
'*geometry_option cdilatation:on',
'*add_geometry_elements',
'all_existing',
]
# ----------------------- MAIN -------------------------------
parser = OptionParser()
parser.add_option("-p", "--port", type="int",\
dest="port",\
help="Mentat connection port")
parser.add_option("-a", "--patchsize", type="float",\
dest="size",\
help="size of patch (x,y,z)")
parser.add_option("-n", "--resolution", type="int",\
dest="resolution",\
help="number of elements along patch perimeter")
parser.add_option("-g", "--margin", type="float", nargs=2,\
dest="margin",\
help="relative size of margin around patch")
parser.add_option("-m", "--mesh", nargs=2, choices=['dt_planar_trimesh','af_planar_trimesh','af_planar_quadmesh'],\
dest="mesh",\
help="algorithm and element type for automeshing: patch and matrix")
parser.add_option("-e", "--strain", type="float",\
dest="strain",\
help="final strain to reach in simulation")
parser.add_option("-r", "--rate", type="float",\
dest="strainrate",\
help="(engineering) strain rate to simulate")
parser.add_option("-i", "--increments", type="int",\
dest="increments",\
help="number of increments to take")
parser.add_option("-s", "--imagesize", type="int",\
dest="imgsize",\
help="size of image")
parser.add_option("-b", "--border", type="int",\
dest="border",\
help="border of image")
parser.add_option("-t", "--tolerance", type="float",\
dest="tolerance",\
help="relative tolerance of pixel positions to be swept")
parser.add_option("-f", "--subroutine", type="string",\
dest="subroutine",\
help="user subroutine file")
parser.add_option("-o", "--domains", type="int",\
dest="domains",\
help="number of domains for domain decomposition")
parser.set_defaults(size = 1.0)
parser.set_defaults(resolution = 30)
parser.set_defaults(margin = [4.0,4.0])
parser.set_defaults(mesh = ['dt_planar_trimesh','dt_planar_trimesh'])
parser.set_defaults(strain = 0.2)
parser.set_defaults(strainrate = 1.0e-3)
parser.set_defaults(increments = 200)
parser.set_defaults(imgsize = 0)
parser.set_defaults(border = 20)
parser.set_defaults(tolerance = 1.0e-3)
parser.set_defaults(subroutine = '/san/'+pwd.getpwuid(os.geteuid())[0].rpartition("\\")[2]+'/FEM/subroutine_svn/mpie_cpfem_marc2007r1.f90')
parser.set_defaults(domains = 1)
(options, args) = parser.parse_args()
if not len(args):
parser.error('no boundary file specified')
try:
boundaryFile = open(args[0])
boundarySegments = boundaryFile.readlines()
boundaryFile.close()
except:
print 'unable to read boundary file "%s"'%args[0]
sys.exit(-1)
myName = os.path.splitext(args[0])[0]
print "\n",myName
orientationData = rcbOrientationParser(boundarySegments)
rcData = rcbParser(boundarySegments,options.size,options.tolerance,myName,options.imgsize,options.border)
# ----- write texture data to file -----
matConfigFile = open(os.path.split(args[0])[0]+'material.config','w')
matConfigFile.write('<homogenization>\n')
matConfigFile.write('\n')
matConfigFile.write('[Taylor]\n')
matConfigFile.write('type\tTaylor\n')
matConfigFile.write('Ngrains\t1\n')
matConfigFile.write('\n')
matConfigFile.write('<microstructure>\n')
matConfigFile.write('\n')
matConfigFile.write('[j2]\n')
matConfigFile.write('(constituent)\tphase 1\ttexture 1\tfraction 1.0\n')
for grain in range(len(rcData['grainMapping'])):
matConfigFile.write('\n')
matConfigFile.write('[grain%i]\n'%(rcData['grainMapping'][grain]))
matConfigFile.write('(constituent)\tphase 2\ttexture %i\tfraction 1.0\n' %(grain+2))
matConfigFile.write('\n')
matConfigFile.write('<phase>\n')
matConfigFile.write('\n')
matConfigFile.write('[phase1]\n')
matConfigFile.write('constitution\t\tj2\n')
matConfigFile.write('(output)\t\tflowstress\n')
matConfigFile.write('c11\t\t\t110.9e9\n')
matConfigFile.write('c12\t\t\t58.34e9\n')
matConfigFile.write('taylorfactor\t\t3\n')
matConfigFile.write('s0\t\t\t31e6\n')
matConfigFile.write('gdot0\t\t\t0.001\n')
matConfigFile.write('n\t\t\t20\n')
matConfigFile.write('h0\t\t\t75e6\n')
matConfigFile.write('s_sat\t\t\t63e6\n')
matConfigFile.write('w0\t\t\t2.25\n')
matConfigFile.write('\n')
matConfigFile.write('[phase2]\n')
matConfigFile.write('constitution\t\tphenomenological\n')
matConfigFile.write('(output)\t\tslipResistance\n')
matConfigFile.write('(output)\t\trateofshear\n')
matConfigFile.write('lattice_structure\tfcc\n')
matConfigFile.write('Nslip\t\t\t12\n')
matConfigFile.write('c11\t\t\t106.75e9\n')
matConfigFile.write('c12\t\t\t60.41e9\n')
matConfigFile.write('c44\t\t\t28.34e9\n')
matConfigFile.write('s0_slip\t\t\t31e6\n')
matConfigFile.write('gdot0_slip\t\t0.001\n')
matConfigFile.write('n_slip\t\t\t20\n')
matConfigFile.write('h0\t\t\t75e6\n')
matConfigFile.write('s_sat\t\t\t63e6\n')
matConfigFile.write('w0\t\t\t2.25\n')
matConfigFile.write('# Self and latent hardening coefficients\n')
matConfigFile.write('hardening_coefficients\t\t1.0 1.4\n')
matConfigFile.write('\n')
matConfigFile.write('<texture>\n')
matConfigFile.write('\n')
matConfigFile.write('[random]\n')
matConfigFile.write('\n')
for grain in rcData['grainMapping']:
matConfigFile.write('[grain %i]\n'%grain)
matConfigFile.write('(gauss)\tphi1 %f\tPhi %f\tphi2 %f\tscatter 0.0\tfraction 1.0\n'\
%(math.degrees(orientationData[grain-1][0]),math.degrees(orientationData[grain-1][1]),math.degrees(orientationData[grain-1][2])))
matConfigFile.write('\n')
matConfigFile.close()
rcData['offsetPoints'] = 1+4 # gage definition generates 4 points
rcData['offsetSegments'] = 1+4 # gage definition generates 4 segments
cmds = [\
init(),
sample(options.size,8,options.margin),
patch(options.size,options.resolution,options.mesh[0],rcData),
gage(options.mesh[1],rcData),
expand3D(options.size/6,4),
cleanUp(options.size),
geometricProperties(),
materialProperties(),
initial_conditions(len(rcData['grain']),rcData['grainMapping']),
boundary_conditions(options.strainrate,options.size/6,options.size,options.margin),
loadcase(options.strain/options.strainrate,options.increments,0.03),
job(len(rcData['grain']),rcData['grainMapping'],options.subroutine,options.domains),
postprocess(),
["*identify_sets","*regen","*fill_view","*save_as_model %s yes"%(myName)],
]
outputLocals = {}
if (options.port != None):
py_connect('',options.port)
output(cmds,outputLocals,'Mentat')
py_disconnect()
else:
output(cmds,outputLocals,'Stdout')
print outputLocals
# "*job_option large:on | large displacement",
# "*job_option plasticity:l_strn_mn_add | large strain additive",
# "*job_option cdilatation:on | constant dilatation",
# "*job_option update:on | updated lagrange procedure",
# "*job_option finite:on | large strains",
# "*job_option restart_mode:write | enable restarting",

18
patch/simplePatch.txt Normal file
View File

@ -0,0 +1,18 @@
# Header: Project2::98168_Zugversuch_Mitte_02 cropped cleaned::All data::Grain Size 11/13/2007
#
# Column 1-3: right hand average orientation (phi1, PHI, phi2 in degrees)
# Column 4-6: left hand average orientation (phi1, PHI, phi2 in degrees)
# Column 7: length (in microns)
# Column 8: trace angle (in degrees)
# Column 9-12: x,y coordinates of endpoints (in microns)
# Column 13-14: IDs of right hand and left hand grains
4.073 0.703 2.983 0.900 0.813 5.039 0.0 0.0 0.00 0.80 0.23 0.63 3 1
1.910 0.727 4.892 0.900 0.813 5.039 0.0 0.0 0.23 0.63 0.55 0.73 4 1
0.012 0.777 0.581 0.900 0.813 5.039 0.0 0.0 0.55 0.73 0.60 1.00 2 1
3.313 0.652 3.103 4.073 0.703 2.983 0.0 0.0 0.00 0.20 0.22 0.30 6 3
1.910 0.727 4.892 4.073 0.703 2.983 0.0 0.0 0.22 0.30 0.23 0.63 4 3
3.313 0.652 3.103 1.910 0.727 4.892 0.0 0.0 0.22 0.30 0.55 0.17 6 4
1.910 0.727 4.892 4.694 0.380 1.246 0.0 0.0 0.78 0.45 0.55 0.17 4 5
4.694 0.380 1.246 0.012 0.777 0.581 0.0 0.0 0.78 0.45 1.00 0.45 5 2
0.012 0.777 0.581 1.910 0.727 4.892 0.0 0.0 0.78 0.45 0.55 0.73 2 4
4.694 0.380 1.246 3.313 0.652 3.103 0.0 0.0 0.57 0.00 0.55 0.17 5 6

BIN
patch/simplePatch_n10_g0505.mud Normal file
View File

Binary file not shown.

805
patch/subroutine/CPFEM.f90 Normal file
View File

@ -0,0 +1,805 @@
!##############################################################
MODULE CPFEM
!##############################################################
! *** CPFEM engine ***
!
use prec, only: pReal,pInt
implicit none
!
! ****************************************************************
! *** General variables for the material behaviour calculation ***
! ****************************************************************
real(pReal), dimension (:,:), allocatable :: CPFEM_Temperature
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_ffn_bar !average FFN per IP
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_ffn !individual FFN per grain
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_ffn1_bar !average FFN1 per IP
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_ffn1 !individual FFN1 per grain
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_PK1_bar !average PK1 per IP
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_PK1 !individual PK1 per grain
real(pReal), dimension (:,:,:,:,:,:), allocatable :: CPFEM_dPdF_bar !average dPdF per IP
real(pReal), dimension (:,:,:,:,:,:), allocatable :: CPFEM_dPdF_bar_old !old average dPdF per IP
real(pReal), dimension (:,:,:,:,:,:,:),allocatable :: CPFEM_dPdF !individual dPdF per grain
real(pReal), dimension (:,:,:), allocatable :: CPFEM_stress_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_jaco_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_jaco_knownGood
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_results
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Lp_old
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Lp_new
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Fp_old
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Fp_new
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Fe_new
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_Tstar_v
logical, dimension (:,:,:), allocatable :: crystallite_converged !individual convergence flag per grain
integer(pInt), dimension(:,:), allocatable :: CPFEM_execution_IP
integer(pInt), dimension(2) :: CPFEM_execution_elem
integer(pInt) :: CPFEM_Nresults = 5_pInt ! phase, volfrac, three Euler angles
logical :: CPFEM_init_done = .false. ! remember whether init has been done already
logical :: CPFEM_calc_done = .false. ! remember whether first IP has already calced the results
real(pReal), parameter :: CPFEM_odd_stress = 1e15_pReal, CPFEM_odd_jacobian = 1e50_pReal
!
CONTAINS
!
!*********************************************************
!*** allocate the arrays defined in module CPFEM ***
!*** and initialize them ***
!*********************************************************
SUBROUTINE CPFEM_init(Temperature)
!
use prec
use math, only: math_EulertoR, math_I3, math_identity2nd
use FEsolving, only: parallelExecution
use mesh
use material
use constitutive
!
implicit none
!
real(pReal) Temperature
integer(pInt) e,i,g
!
! *** mpie.marc parameters ***
allocate(CPFEM_Temperature(mesh_maxNips,mesh_NcpElems)) ; CPFEM_Temperature = Temperature
allocate(CPFEM_ffn_bar(3,3,mesh_maxNips,mesh_NcpElems))
forall(e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn_bar(:,:,i,e) = math_I3
allocate(CPFEM_ffn(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems))
forall(g=1:homogenization_maxNgrains,e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn(:,:,g,i,e) = math_I3
allocate(CPFEM_ffn1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1_bar = CPFEM_ffn_bar
allocate(CPFEM_ffn1(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1 = CPFEM_ffn
allocate(CPFEM_PK1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1_bar = 0.0_pReal
allocate(CPFEM_PK1(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1 = 0.0_pReal
allocate(CPFEM_dPdF_bar(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar = 0.0_pReal
allocate(CPFEM_dPdF_bar_old(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar_old = 0.0_pReal
allocate(CPFEM_dPdF(3,3,3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF = 0.0_pReal
allocate(CPFEM_stress_bar(6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_stress_bar = 0.0_pReal
allocate(CPFEM_jaco_bar(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_jaco_bar = 0.0_pReal
allocate(CPFEM_jaco_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_jaco_knownGood = 0.0_pReal
!
! *** User defined results ***
allocate(CPFEM_results(CPFEM_Nresults+constitutive_maxSizePostResults,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems))
CPFEM_results = 0.0_pReal
!
! *** Plastic velocity gradient ***
allocate(CPFEM_Lp_old(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_old = 0.0_pReal
allocate(CPFEM_Lp_new(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_new = 0.0_pReal
! *** Plastic deformation gradient at (t=t0) and (t=t1) ***
allocate(CPFEM_Fp_new(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fp_new = 0.0_pReal
allocate(CPFEM_Fp_old(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems))
forall (e=1:mesh_NcpElems,i=1:mesh_maxNips,g=1:homogenization_maxNgrains) &
CPFEM_Fp_old(:,:,g,i,e) = math_EulerToR(material_EulerAngles(:,g,i,e)) ! plastic def gradient reflects init orientation
! *** Elastic deformation gradient at (t=t1) ***
allocate(CPFEM_Fe_new(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fe_new = 0.0_pReal
! *** Stress vector at (t=t1) ***
allocate(CPFEM_Tstar_v(6,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Tstar_v = 0.0_pReal
!
allocate(crystallite_converged(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)); crystallite_converged = .false.
allocate(CPFEM_execution_IP(2,mesh_NcpElems)); CPFEM_execution_IP = 1_pInt
forall (e = 1:mesh_NcpElems) CPFEM_execution_IP(2,e) = FE_Nips(mesh_element(2,e))
CPFEM_execution_elem = (/1,mesh_NcpElems/)
! *** Output to MARC output file ***
!$OMP CRITICAL (write2out)
write(6,*)
write(6,*) 'CPFEM Initialization'
write(6,*)
write(6,*) 'CPFEM_Temperature: ', shape(CPFEM_Temperature)
write(6,*) 'CPFEM_ffn_bar: ', shape(CPFEM_ffn_bar)
write(6,*) 'CPFEM_ffn: ', shape(CPFEM_ffn)
write(6,*) 'CPFEM_ffn1_bar: ', shape(CPFEM_ffn1_bar)
write(6,*) 'CPFEM_ffn1: ', shape(CPFEM_ffn1)
write(6,*) 'CPFEM_PK1_bar: ', shape(CPFEM_PK1_bar)
write(6,*) 'CPFEM_PK1: ', shape(CPFEM_PK1)
write(6,*) 'CPFEM_dPdF_bar: ', shape(CPFEM_dPdF_bar)
write(6,*) 'CPFEM_dPdF_bar_old: ', shape(CPFEM_dPdF_bar_old)
write(6,*) 'CPFEM_dPdF: ', shape(CPFEM_dPdF)
write(6,*) 'CPFEM_stress_bar: ', shape(CPFEM_stress_bar)
write(6,*) 'CPFEM_jaco_bar: ', shape(CPFEM_jaco_bar)
write(6,*) 'CPFEM_jaco_knownGood: ', shape(CPFEM_jaco_knownGood)
write(6,*) 'CPFEM_results: ', shape(CPFEM_results)
write(6,*) 'CPFEM_Lp_old: ', shape(CPFEM_Lp_old)
write(6,*) 'CPFEM_Lp_new: ', shape(CPFEM_Lp_new)
write(6,*) 'CPFEM_Fp_old: ', shape(CPFEM_Fp_old)
write(6,*) 'CPFEM_Fp_new: ', shape(CPFEM_Fp_new)
write(6,*) 'CPFEM_Fe_new: ', shape(CPFEM_Fe_new)
write(6,*) 'CPFEM_Tstar_v: ', shape(CPFEM_Tstar_v)
write(6,*) 'crystallite_converged:', shape(crystallite_converged)
write(6,*)
write(6,*) 'parallelExecution: ', parallelExecution
call flush(6)
!$OMP END CRITICAL (write2out)
return
!
END SUBROUTINE
!
!
!***********************************************************************
!*** perform initialization at first call, update variables and ***
!*** call the actual material model ***
!
! CPFEM_mode computation mode (regular, collection, recycle)
! ffn deformation gradient for t=t0
! ffn1 deformation gradient for t=t1
! Temperature temperature
! CPFEM_dt time increment
! CPFEM_en element number
! CPFEM_in intergration point number
! CPFEM_stress stress vector in Mandel notation
! CPFEM_updateJaco flag to initiate computation of Jacobian
! CPFEM_jaco jacobian in Mandel notation
! CPFEM_ngens size of stress strain law
!***********************************************************************
SUBROUTINE CPFEM_general(CPFEM_mode, ffn, ffn1, Temperature, CPFEM_dt,&
CPFEM_en, CPFEM_in, CPFEM_stress, CPFEM_updateJaco, CPFEM_jaco, CPFEM_ngens)
! note: CPFEM_stress = Cauchy stress cs(6) and CPFEM_jaco = Consistent tangent dcs/de
!
use prec, only: pReal,pInt
use FEsolving
use debug
use math
use mesh, only: mesh_init,mesh_FEasCP, mesh_NcpElems, mesh_maxNips, mesh_element
use lattice, only: lattice_init
use material
use constitutive, only: constitutive_init,constitutive_state_old,constitutive_state_new
implicit none
!
integer(pInt) CPFEM_en, CPFEM_in, cp_en, CPFEM_ngens, i,j,k,l,m,n
real(pReal), dimension (3,3) :: ffn,ffn1,Kirchhoff_bar
real(pReal), dimension (3,3,3,3) :: H_bar, H_bar_sym
real(pReal), dimension(CPFEM_ngens) :: CPFEM_stress
real(pReal), dimension(CPFEM_ngens,CPFEM_ngens) :: CPFEM_jaco
real(pReal) Temperature,CPFEM_dt,J_inverse
integer(pInt) CPFEM_mode ! 1: regular computation with aged results&
! 2: regular computation&
! 3: collection of FEM data&
! 4: recycling of former results (MARC speciality)&
! 5: record tangent from former converged inc&
! 6: restore tangent from former converged inc
logical CPFEM_updateJaco
!
if (.not. CPFEM_init_done) then ! initialization step (three dimensional stress state check missing?)
call math_init()
call FE_init()
call mesh_init()
call lattice_init()
call material_init()
call constitutive_init()
write (6,*) 'call CPFEM init'
call CPFEM_init(Temperature)
CPFEM_init_done = .true.
endif
!
if ((.not. parallelExecution) .and. (CPFEM_mode == 3)) CPFEM_mode = 2
!
cp_en = mesh_FEasCP('elem',CPFEM_en)
if (cp_en == 1 .and. CPFEM_in == 1) then
write(6,'(a10,1x,f8.4,1x,a10,1x,i4,1x,a10,1x,i3,1x,a10,1x,i2,x,a10,1x,i2)') &
'theTime',theTime,'theInc',theInc,'theCycle',theCycle,'theLovl',theLovl,&
'mode',CPFEM_mode
endif
!
select case (CPFEM_mode)
case (1,2) ! regular computation (with aging of results if mode == 1)
if (CPFEM_mode == 1) then ! age results at start of new increment
CPFEM_Lp_old = CPFEM_Lp_new
CPFEM_Fp_old = CPFEM_Fp_new
forall (i = 1:homogenization_maxNgrains,&
j = 1:mesh_maxNips, &
k = 1:mesh_NcpElems) &
constitutive_state_old(i,j,k)%p = constitutive_state_new(i,j,k)%p
write (6,*) 'results aged.'
endif
if (outdatedFFN1 .or. any(abs(ffn1 - CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en)) > relevantStrain)&
.and. parallelExecution) then
if (.not. outdatedFFN1) write(6,'(i5,x,i2,x,a10,/,3(3(f10.3,x),/))') cp_en,CPFEM_in,'FFN1 now:',ffn1(:,1),ffn1(:,2),ffn1(:,3)
outdatedFFN1 = .true.
CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
else
if (.not. parallelExecution) then
CPFEM_execution_elem(1) = cp_en
CPFEM_execution_elem(2) = cp_en
CPFEM_execution_IP(1,cp_en) = CPFEM_in
CPFEM_execution_IP(2,cp_en) = CPFEM_in
CPFEM_Temperature(CPFEM_in,cp_en) = Temperature
CPFEM_ffn_bar(:,:,CPFEM_in,cp_en) = ffn
CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) = ffn1
call CPFEM_MaterialPoint(CPFEM_updateJaco, CPFEM_dt)
elseif (.not. CPFEM_calc_done) then
call CPFEM_MaterialPoint(CPFEM_updateJaco, CPFEM_dt) ! parallel execution inside
CPFEM_calc_done = .true.
endif
! translate from P and dP/dF to CS and dCS/dE
Kirchhoff_bar = math_mul33x33(CPFEM_PK1_bar(:,:,CPFEM_in, cp_en),transpose(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en)))
J_inverse = 1.0_pReal/math_det3x3(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en))
CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel33to6(J_inverse*Kirchhoff_bar)
!
H_bar = 0.0_pReal
forall(i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
H_bar(i,j,k,l) = H_bar(i,j,k,l) + &
CPFEM_ffn1_bar(j,m,CPFEM_in,cp_en) * &
CPFEM_ffn1_bar(l,n,CPFEM_in,cp_en) * &
CPFEM_dPdF_bar(i,m,k,n,CPFEM_in,cp_en) - &
math_I3(j,l)*CPFEM_ffn1_bar(i,m,CPFEM_in,cp_en)*CPFEM_PK1_bar(k,m,CPFEM_in,cp_en) + &
0.5_pReal*(math_I3(i,k)*Kirchhoff_bar(j,l) + math_I3(j,l)*Kirchhoff_bar(i,k) + &
math_I3(i,l)*Kirchhoff_bar(j,k) + math_I3(j,k)*Kirchhoff_bar(i,l))
forall(i=1:3,j=1:3,k=1:3,l=1:3) &
H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel3333to66(J_inverse*H_bar)
endif
case (3) ! collect and return odd result
CPFEM_Temperature(CPFEM_in,cp_en) = Temperature
CPFEM_ffn_bar(:,:,CPFEM_in,cp_en) = ffn
CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) = ffn1
CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
CPFEM_calc_done = .false.
case (4) ! do nothing since we can recycle the former results (MARC specialty)
case (5) ! record consistent tangent at beginning of new increment (while recycling)
CPFEM_jaco_knownGood = CPFEM_jaco_bar
case (6) ! restore consistent tangent after cutback
CPFEM_jaco_bar = CPFEM_jaco_knownGood
end select
!
! return the local stress and the jacobian from storage
CPFEM_stress(1:CPFEM_ngens) = CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en)
CPFEM_jaco(1:CPFEM_ngens,1:CPFEM_ngens) = CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en)
!
return
!
END SUBROUTINE
!
!
!**********************************************************
!*** calculate the material point behaviour ***
!**********************************************************
SUBROUTINE CPFEM_MaterialPoint(&
updateJaco,& ! flag to initiate Jacobian updating
CPFEM_dt) ! Time increment (dt)
!
use prec
use debug
use math, only: math_pDecomposition,math_RtoEuler,inDeg
use IO, only: IO_error
use mesh, only: mesh_element, mesh_NcpElems, FE_Nips
use material, only: homogenization_Ngrains,material_phase,material_volfrac
use constitutive
implicit none
!
logical, intent(in) :: updateJaco
real(pReal), intent(in) :: CPFEM_dt
integer(pInt) g,i,e
logical error
real(pReal), dimension(3,3) :: U,R
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
forall (g = 1:homogenization_Ngrains(mesh_element(3,e))) ! number of grains of this homogenization
CPFEM_ffn(:,:,g,i,e) = CPFEM_ffn_bar(:,:,i,e) ! Taylor homogenization (why not using former ffn1??)
CPFEM_ffn1(:,:,g,i,e) = CPFEM_ffn1_bar(:,:,i,e) ! Taylor homogenization
end forall
enddo
enddo
!$OMP END PARALLEL DO
call SingleCrystallite(updateJaco,CPFEM_dt)
!******************************************************************************************************
! check convergence of homogenization if needed
!******************************************************************************************************
! calculate average quantities per ip and post results
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
CPFEM_PK1_bar(:,:,i,e) = sum(CPFEM_PK1(:,:,:,i,e),3)/homogenization_Ngrains(mesh_element(3,e))
if (updateJaco) &
CPFEM_dPdF_bar(:,:,:,:,i,e) = &
sum(CPFEM_dPdF(:,:,:,:,:,i,e),5)/homogenization_Ngrains(mesh_element(3,e)) ! add up crystallite stiffnesses (may have "holes" corresponding to former avg tangent)
do g = 1,homogenization_Ngrains(mesh_element(3,e))
call math_pDecomposition(CPFEM_Fe_new(:,:,g,i,e),U,R,error) ! polar decomposition
if (error) call IO_error(650,e,i,g)
CPFEM_results(1,g,i,e) = material_phase(g,i,e)
CPFEM_results(2,g,i,e) = material_volFrac(g,i,e)
CPFEM_results(3:5,g,i,e) = math_RtoEuler(transpose(R))*inDeg ! orientation
enddo
enddo
enddo
!$OMP END PARALLEL DO
return
END SUBROUTINE
!********************************************************************
! Calculates the stress and jacobi (if wanted) for all or a single component
!********************************************************************
subroutine SingleCrystallite(&
updateJaco,& ! update of Jacobian required
dt) ! time increment
use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
use debug
use math
use IO, only: IO_error
use mesh, only: mesh_element, FE_Nips
use material, only: homogenization_Ngrains
use constitutive
implicit none
character (len=128) msg
logical updateJaco, allConverged
real(preal) dt
real(pReal), dimension(3,3) :: Fg_pert,Lp_pert, P_pert, Fp_pert, Fe_pert
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(constitutive_maxSizeState) :: state
integer(pInt) g,i,e,k,l,iOuter,mySizeState
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
forall (g = 1:homogenization_Ngrains(mesh_element(3,e))) ! number of grains of this homogenization
crystallite_converged(g,i,e) = .false.
constitutive_state_new(g,i,e)%p = constitutive_state_old(g,i,e)%p
CPFEM_Lp_new(:,:,g,i,e) = CPFEM_Lp_old(:,:,g,i,e)
end forall
end do
end do
!$OMP END PARALLEL DO
iOuter = 0_pInt
allConverged = .false.
do while (.not. allConverged)
iOuter = iOuter + 1_pInt ! count state integation loops
if (iOuter > nOuter) call IO_error(600) ! too many loops required --> croak
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
do g = 1,homogenization_Ngrains(mesh_element(3,e)) ! number of grains of this homogenization
if (.not. crystallite_converged(g,i,e)) then
call integrateStress(msg,CPFEM_Tstar_v(:,g,i,e),CPFEM_PK1(:,:,g,i,e), &
CPFEM_Fp_new(:,:,g,i,e),CPFEM_Fe_new(:,:,g,i,e),CPFEM_Lp_new(:,:,g,i,e), &
CPFEM_ffn1(:,:,g,i,e),dt,g,i,e)
if (msg /= 'ok') call IO_error(610,e,i,g,msg)
endif
end do
end do
end do
!$OMP END PARALLEL DO
allConverged = .true. ! assume best case
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
do g = 1,homogenization_Ngrains(mesh_element(3,e)) ! number of grains of this homogenization
if (crystallite_converged(g,i,e)) cycle ! this one is already fine
if (integrateState(CPFEM_Tstar_v(:,g,i,e),dt,g,i,e)) then ! state integration now converged?
crystallite_converged(g,i,e) = .true.
!$OMP CRITICAL (out)
debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
!$OMP END CRITICAL (out)
else
allConverged = .false. ! this one requires additional round...
endif
end do
end do
end do
!$OMP END PARALLEL DO
end do ! all crystallites converged
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
forall (g = 1:homogenization_Ngrains(mesh_element(3,e))) & ! number of grains of this homogenization
CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_sizePostResults(g,i,e),g,i,e) = &
constitutive_postResults(CPFEM_Tstar_v(:,g,i,e),CPFEM_Temperature(i,e),dt,g,i,e)
end do
end do
!$OMP END PARALLEL DO
if(updateJaco) then ! Jacobian required
!$OMP CRITICAL (write2out)
if (debugger) write (6,*) 'Jacobian calc'
!$OMP END CRITICAL (write2out)
!$OMP PARALLEL DO
do e = CPFEM_execution_elem(1),CPFEM_execution_elem(2) ! iterate over elements to be processed
do i = CPFEM_execution_IP(1,e),CPFEM_execution_IP(2,e) ! iterate over IPs of this element to be processed
do g = 1,homogenization_Ngrains(mesh_element(3,e)) ! number of grains of this homogenization
mySizeState = constitutive_sizeState(g,i,e) ! number of state variables for this grain
state(1:mySizeState) = constitutive_state_new(g,i,e)%p ! remember unperturbed, converged state
do k = 1,3 ! perturbation...
do l = 1,3 ! ...components
Fg_pert = CPFEM_ffn1(:,:,g,i,e) ! initialize perturbed Fg
Fg_pert(k,l) = Fg_pert(k,l) + pert_Fg ! perturb single component
Lp_pert = CPFEM_Lp_new(:,:,g,i,e) ! initialize Lp
Fp_pert = CPFEM_Fp_new(:,:,g,i,e) ! initialize Fp
constitutive_state_new(g,i,e)%p = state(1:mySizeState) ! initial guess from end of time step
crystallite_converged(g,i,e) = .false.
iOuter = 0_pInt
do while(.not. crystallite_converged(g,i,e) .and. iOuter < nOuter)
iOuter = iOuter + 1_pInt
call integrateStress(msg,Tstar_v,P_pert,Fp_pert,Fe_pert,Lp_pert, Fg_pert,dt,g,i,e)
if (msg /= 'ok') exit
crystallite_converged(g,i,e) = integrateState(Tstar_v,dt,g,i,e)
end do
if (crystallite_converged(g,i,e)) &
CPFEM_dPdF(:,:,k,l,g,i,e) = (P_pert-CPFEM_PK1(:,:,g,i,e))/pert_Fg ! constructing tangent dP_ij/dFg_kl only if valid forward difference
!$OMP CRITICAL (out)
debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
!$OMP END CRITICAL (out)
end do
end do
constitutive_state_new(g,i,e)%p = state(1:mySizeState) ! restore solution
end do
end do
end do
!$OMP END PARALLEL DO
endif
return
end subroutine
!********************************************************************
! Update the state for a single component
!********************************************************************
function integrateState(&
Tstar_v,& ! stress
dt,& ! time increment
g,& ! grain number
i,& ! integration point number
e& ! element number
)
use prec, only: pReal,pInt,pLongInt,reltol_Outer
use constitutive, only: constitutive_dotState,constitutive_sizeDotState,&
constitutive_state_old,constitutive_state_new
use debug
logical integrateState
integer(pLongInt) tick,tock,tickrate,maxticks
integer(pInt) g,i,e,mySize
real(pReal), dimension(6) :: Tstar_v
real(pReal) dt
real(pReal), dimension(constitutive_sizeDotState(g,i,e)) :: residuum
mySize = constitutive_sizeDotState(g,i,e)
call system_clock(count=tick,count_rate=tickrate,count_max=maxticks)
residuum = constitutive_state_new(g,i,e)%p(1:mySize) - constitutive_state_old(g,i,e)%p(1:mySize) - &
dt*constitutive_dotState(Tstar_v,CPFEM_Temperature(i,e),g,i,e) ! residuum from evolution of microstructure
call system_clock(count=tock,count_rate=tickrate,count_max=maxticks)
debug_cumDotStateCalls = debug_cumDotStateCalls + 1_pInt
debug_cumDotStateTicks = debug_cumDotStateTicks + tock-tick
if (tock < tick) debug_cumDotStateTicks = debug_cumDotStateTicks + maxticks
constitutive_state_new(g,i,e)%p(1:mySize) = constitutive_state_new(g,i,e)%p(1:mySize) - residuum ! update of microstructure
integrateState = maxval(abs(residuum/constitutive_state_new(g,i,e)%p(1:mySize)),&
constitutive_state_new(g,i,e)%p(1:mySize) /= 0.0_pReal) < reltol_Outer
return
end function
!********************************************************************
! Calculates the stress for a single component
!********************************************************************
!***********************************************************************
!*** calculation of stress (P), stiffness (dPdF), ***
!*** and announcement of any ***
!*** acceleration of the Newton-Raphson correction ***
!***********************************************************************
subroutine integrateStress(&
msg,& ! return message
Tstar_v,& ! Stress vector
P,& ! first PK stress
Fp_new,& ! new plastic deformation gradient
Fe_new,& ! new "elastic" deformation gradient
Lp,& ! plastic velocity gradient
!
Fg_new,& ! new global deformation gradient
dt,& ! time increment
g,& ! grain number
i,& ! integration point number
e) ! element number
use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
use debug
use constitutive, only: constitutive_state_new
use math
! use CPFEM
!
implicit none
!
character(len=*) msg
logical error,success
integer(pInt) e,i,g, nCutbacks, maxCutbacks
real(pReal) Temperature
real(pReal) dt,dt_aim,subFrac,subStep,det
real(pReal), dimension(3,3) :: Lp,Lp_interpolated,inv
real(pReal), dimension(3,3) :: Fg_current,Fg_new,Fg_aim,deltaFg
real(pReal), dimension(3,3) :: Fp_current,Fp_new
real(pReal), dimension(3,3) :: Fe_current,Fe_new
real(pReal), dimension(3,3) :: P
real(pReal), dimension(6) :: Tstar_v
deltaFg = Fg_new - CPFEM_ffn(:,:,g,i,e)
subFrac = 0.0_pReal
subStep = 1.0_pReal
nCutbacks = 0_pInt
maxCutbacks = 0_pInt
Fg_current = CPFEM_ffn(:,:,g,i,e) ! initialize to start of inc
Fp_current = CPFEM_Fp_old(:,:,g,i,e)
call math_invert3x3(Fp_current,inv,det,error)
Fe_current = math_mul33x33(Fg_current,inv)
success = .false. ! pretend cutback
dt_aim = 0.0_pReal ! prevent initial Lp interpolation
Temperature = CPFEM_Temperature(i,e)
! begin the cutback loop
do while (subStep > subStepMin) ! continue until finished or too much cut backing
if (success) then ! wind forward
Fg_current = Fg_aim
Fe_current = Fe_new
Fp_current = Fp_new
elseif (dt_aim > 0.0_pReal) then
call math_invert3x3(Fg_aim,inv,det,error) ! inv of Fg_aim
Lp_interpolated = 0.5_pReal*Lp + &
0.5_pReal*(math_I3 - math_mul33x33(Fp_current,&
math_mul33x33(inv,Fe_current)))/dt_aim ! interpolate Lp and L
if (debugger) then
!$OMP CRITICAL (write2out)
write (6,*) 'Lp interpolation'
write (6,'(a,/,3(3(f12.7,x)/))') 'from',Lp(1:3,:)
write (6,'(a,/,3(3(f12.7,x)/))') 'to',Lp_interpolated(1:3,:)
!$OMP END CRITICAL (write2out)
endif
Lp = Lp_interpolated
endif
!
Fg_aim = Fg_current + subStep*deltaFg ! aim for Fg
dt_aim = subStep*dt ! aim for dt
if (debugger) then
!$OMP CRITICAL (write2out)
write (6,*) 'using these values'
write (6,'(a,/,3(4(f9.3,x)/))') 'state new / MPa',constitutive_state_new(g,i,e)%p/1e6_pReal
write (6,'(a,/,3(3(f12.7,x)/))') 'Fe current',Fe_current(1:3,:)
write (6,'(a,/,3(3(f12.7,x)/))') 'Fp current',Fp_current(1:3,:)
write (6,'(a,/,3(3(f12.7,x)/))') 'Lp (old=new guess)',Lp(1:3,:)
write (6,'(a20,f,x,a2,x,f)') 'integrating from ',subFrac,'to',(subFrac+subStep)
!$OMP END CRITICAL (write2out)
endif
call TimeIntegration(msg,Lp,Fp_new,Fe_new,Tstar_v,P, Fg_aim,Fp_current,Temperature,dt_aim,g,i,e)
if (msg == 'ok') then
subFrac = subFrac + subStep
subStep = min(1.0_pReal-subFrac, subStep*2.0_pReal) ! accelerate
nCutbacks = 0_pInt ! reset cutback counter
success = .true. ! keep current Lp
else
nCutbacks = nCutbacks + 1 ! record additional cutback
maxCutbacks = max(nCutbacks,maxCutbacks) ! remember maximum number of cutbacks
subStep = subStep / 2.0_pReal ! cut time step in half
success = .false. ! force Lp interpolation
endif
enddo ! potential substepping
!
!$OMP CRITICAL (cutback)
debug_cutbackDistribution(min(nCutback,maxCutbacks)+1) = debug_cutbackDistribution(min(nCutback,maxCutbacks)+1)+1
!$OMP END CRITICAL (cutback)
return
end subroutine
!
!***********************************************************************
!*** fully-implicit two-level time integration ***
!*** based on a residuum in Lp and intermediate ***
!*** acceleration of the Newton-Raphson correction ***
!***********************************************************************
SUBROUTINE TimeIntegration(&
msg,& ! return message
Lpguess,& ! guess of plastic velocity gradient
Fp_new,& ! new plastic deformation gradient
Fe_new,& ! new "elastic" deformation gradient
Tstar_v,& ! Stress vector
P,& ! 1st PK stress (taken as initial guess if /= 0)
Fg_new,& ! new total def gradient
Fp_old,& ! former plastic def gradient
Temperature,& ! temperature
dt,& ! time increment
grain,& ! grain number
ip,& ! integration point number
cp_en & ! element number
)
use prec
use debug
use mesh, only: mesh_element
use constitutive, only: constitutive_microstructure,constitutive_homogenizedC,constitutive_LpAndItsTangent,&
constitutive_state_new
use math
use IO
implicit none
!
character(len=*) msg
logical failed
integer(pInt) cp_en, ip, grain
integer(pInt) iInner,dummy, i,j,k,l,m,n
integer(pLongInt) tick,tock,tickrate,maxticks
real(pReal) dt, Temperature, det, p_hydro, leapfrog,maxleap
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(9,9) :: dLp,dTdLp,dRdLp,invdRdLp,eye2
real(pReal), dimension(6,6) :: C_66
real(pReal), dimension(3,3) :: Fg_new,Fp_new,invFp_new,Fp_old,invFp_old,Fe_new
real(pReal), dimension(3,3) :: P
real(pReal), dimension(3,3) :: Lp,Lpguess,Lpguess_old,Rinner,Rinner_old,A,B,BT,AB,BTA
real(pReal), dimension(3,3,3,3) :: C
msg = 'ok' ! error-free so far
eye2 = math_identity2nd(9)
call math_invert3x3(Fp_old,invFp_old,det,failed) ! inversion of Fp_old
if (failed) then
msg = 'inversion Fp_old'
return
endif
A = math_mul33x33(transpose(invFp_old), math_mul33x33(transpose(Fg_new),math_mul33x33(Fg_new,invFp_old)))
!$OMP CRITICAL (write2out)
if (debugger) write (6,'(a,/,3(3(f12.7,x)/))') 'Fg to be calculated',Fg_new
!$OMP END CRITICAL (write2out)
call constitutive_microstructure(Temperature,grain,ip,cp_en)
C_66 = constitutive_homogenizedC(grain,ip,cp_en)
C = math_Mandel66to3333(C_66) ! 4th rank elasticity tensor
iInner = 0_pInt
leapfrog = 1.0_pReal ! correction as suggested by invdRdLp-step
maxleap = 1024.0_pReal ! preassign maximum acceleration level
Lpguess_old = Lpguess ! consider present Lpguess good
Inner: do ! inner iteration: Lp
iInner = iInner+1
if (iInner > nInner) then ! too many loops required
Lpguess = Lpguess_old ! do not trust the last update but resort to former one
msg = 'limit Inner iteration'
return
endif
B = math_i3 - dt*Lpguess
BT = transpose(B)
AB = math_mul33x33(A,B)
BTA = math_mul33x33(BT,A)
Tstar_v = 0.5_pReal*math_mul66x6(C_66,math_mandel33to6(math_mul33x33(BT,AB)-math_I3))
p_hydro=(Tstar_v(1)+Tstar_v(2)+Tstar_v(3))/3.0_pReal
forall(i=1:3) Tstar_v(i) = Tstar_v(i)-p_hydro ! subtract hydrostatic pressure
call system_clock(count=tick,count_rate=tickrate,count_max=maxticks)
call constitutive_LpAndItsTangent(Lp,dLp, Tstar_v,Temperature,grain,ip,cp_en)
call system_clock(count=tock,count_rate=tickrate,count_max=maxticks)
debug_cumLpCalls = debug_cumLpCalls + 1_pInt
debug_cumLpTicks = debug_cumLpTicks + tock-tick
if (tock < tick) debug_cumLpTicks = debug_cumLpTicks + maxticks
Rinner = Lpguess - Lp ! update current residuum
if (.not.(any(Rinner/=Rinner)) .and. & ! exclude any NaN in residuum
( ( maxval(abs(Rinner)) < abstol_Inner) .or. & ! below abs tol .or.
( any(abs(dt*Lpguess) > relevantStrain) .and. & ! worth checking? .and.
maxval(abs(Rinner/Lpguess),abs(dt*Lpguess) > relevantStrain) < reltol_Inner & ! below rel tol
) &
) &
) &
exit Inner ! convergence
!
! check for acceleration/deceleration in Newton--Raphson correction
!
if (any(Rinner/=Rinner) .and. & ! NaN occured at regular speed
leapfrog == 1.0) then
Lpguess = Lpguess_old ! restore known good guess
msg = 'NaN present' ! croak for cutback
return
elseif (leapfrog > 1.0_pReal .and. & ! at fast pace ?
(sum(Rinner*Rinner) > sum(Rinner_old*Rinner_old) .or. & ! worse residuum
sum(Rinner*Rinner_old) < 0.0_pReal) .or. & ! residuum changed sign (overshoot)
any(Rinner/=Rinner) ) then ! NaN
maxleap = 0.5_pReal * leapfrog ! limit next acceleration
leapfrog = 1.0_pReal ! grinding halt
else ! better residuum
dTdLp = 0.0_pReal ! calc dT/dLp
forall (i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
dTdLp(3*(i-1)+j,3*(k-1)+l) = dTdLp(3*(i-1)+j,3*(k-1)+l) + &
C(i,j,l,n)*AB(k,n)+C(i,j,m,l)*BTA(m,k)
dTdLp = -0.5_pReal*dt*dTdLp
dRdLp = eye2 - math_mul99x99(dLp,dTdLp) ! calc dR/dLp
invdRdLp = 0.0_pReal
call math_invert(9,dRdLp,invdRdLp,dummy,failed) ! invert dR/dLp --> dLp/dR
if (failed) then
msg = 'inversion dR/dLp'
if (debugger) then
!$OMP CRITICAL (write2out)
write (6,*) msg
write (6,'(a,/,9(9(e9.3,x)/))') 'dRdLp', dRdLp(1:9,:)
write (6,'(a,/,3(4(f9.3,x)/))') 'state_new / MPa',constitutive_state_new(grain,ip,cp_en)%p/1e6_pReal
write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
write (6,'(a,/,3(3(e12.7,x)/))') 'Lp',Lp(1:3,:)
write (6,'(a,/,6(f9.3,x))') 'Tstar / MPa',Tstar_v/1e6_pReal
!$OMP END CRITICAL (write2out)
endif
return
endif
!
Rinner_old = Rinner ! remember current residuum
Lpguess_old = Lpguess ! remember current Lp guess
if (iInner > 1 .and. leapfrog < maxleap) leapfrog = 2.0_pReal * leapfrog ! accelerate if ok
endif
!
Lpguess = Lpguess_old ! start from current guess
Rinner = Rinner_old ! use current residuum
forall (i=1:3,j=1:3,k=1:3,l=1:3) & ! leapfrog to updated Lpguess
Lpguess(i,j) = Lpguess(i,j) - leapfrog*invdRdLp(3*(i-1)+j,3*(k-1)+l)*Rinner(k,l)
enddo Inner
!
!$OMP CRITICAL (in)
debug_InnerLoopDistribution(iInner) = debug_InnerLoopDistribution(iInner)+1
!$OMP END CRITICAL (in)
invFp_new = math_mul33x33(invFp_old,B)
call math_invert3x3(invFp_new,Fp_new,det,failed)
if (failed) then
msg = 'inversion Fp_new^-1'
return
endif
Fp_new = Fp_new*det**(1.0_pReal/3.0_pReal) ! regularize Fp by det = det(InvFp_new) !!
forall (i=1:3) Tstar_v(i) = Tstar_v(i) + p_hydro ! add hydrostatic component back
Fe_new = math_mul33x33(Fg_new,invFp_new) ! calc resulting Fe
P = math_mul33x33(Fe_new,math_mul33x33(math_Mandel6to33(Tstar_v),transpose(invFp_new))) ! first PK stress
return
!
END SUBROUTINE
!
END MODULE
!##############################################################

893
patch/subroutine/CPFEM_GIA8.f90 Normal file
View File

@ -0,0 +1,893 @@
!##############################################################
MODULE CPFEM
!##############################################################
! *** CPFEM engine ***
!
use prec, only: pReal,pInt
implicit none
!
! ****************************************************************
! *** General variables for the material behaviour calculation ***
! ****************************************************************
real(pReal), dimension (:,:), allocatable :: CPFEM_Temperature
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_ffn_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_ffn1_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_PK1_bar
real(pReal), dimension (:,:,:,:,:,:),allocatable :: CPFEM_dPdF_bar
real(pReal), dimension (:,:,:), allocatable :: CPFEM_stress_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_jaco_bar
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_jaco_knownGood
real(pReal), dimension (:,:,:,:), allocatable :: CPFEM_results
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Fp_old
real(pReal), dimension (:,:,:,:,:), allocatable :: CPFEM_Fp_new
real(pReal), parameter :: CPFEM_odd_stress = 1e15_pReal, CPFEM_odd_jacobian = 1e50_pReal
integer(pInt) :: CPFEM_Nresults = 4_pInt ! three Euler angles plus volume fraction
logical :: CPFEM_init_done = .false. ! remember if init has been done already
logical :: CPFEM_calc_done = .false. ! remember if first IP has already calced the results
!
real(pReal), dimension (:,:,:,:), allocatable :: GIA_rVect_new ! boundary relaxation vectors
real(pReal), dimension (:,:,:,:), allocatable :: GIA_rVect_old ! boundary relaxation vectors
real(pReal), dimension (:,:), allocatable :: GIA_bNorm ! grain boundary normals
!
CONTAINS
!
!*********************************************************
!*** allocate the arrays defined in module CPFEM ***
!*** and initialize them ***
!*********************************************************
SUBROUTINE CPFEM_init(Temperature)
!
use prec
use math, only: math_EulertoR, math_I3, math_identity2nd
use mesh
use constitutive
!
implicit none
!
real(pReal) Temperature
integer(pInt) e,i,g,b
!
! *** mpie.marc parameters ***
allocate(CPFEM_Temperature (mesh_maxNips,mesh_NcpElems)) ; CPFEM_Temperature = Temperature
allocate(CPFEM_ffn_bar (3,3,mesh_maxNips,mesh_NcpElems))
forall(e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn_bar(:,:,i,e) = math_I3
allocate(CPFEM_ffn1_bar (3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1_bar = CPFEM_ffn_bar
allocate(CPFEM_PK1_bar (3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1_bar = 0.0_pReal
allocate(CPFEM_dPdF_bar(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar = 0.0_pReal
allocate(CPFEM_stress_bar(6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_stress_bar = 0.0_pReal
allocate(CPFEM_jaco_bar(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_jaco_bar = 0.0_pReal
allocate(CPFEM_jaco_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_jaco_knownGood = 0.0_pReal
!
! *** User defined results !!! MISSING incorporate consti_Nresults ***
allocate(CPFEM_results(CPFEM_Nresults+constitutive_maxNresults,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
CPFEM_results = 0.0_pReal
!
! *** Plastic deformation gradient at (t=t0) and (t=t1) ***
allocate(CPFEM_Fp_new(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fp_new = 0.0_pReal
allocate(CPFEM_Fp_old(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
forall (e=1:mesh_NcpElems,i=1:mesh_maxNips,g=1:constitutive_maxNgrains) &
CPFEM_Fp_old(:,:,g,i,e) = math_EulerToR(constitutive_EulerAngles(:,g,i,e)) ! plastic def gradient reflects init orientation
!
allocate(GIA_rVect_new(3,12,mesh_maxNips,mesh_NcpElems)) ; GIA_rVect_new = 0.0_pReal
allocate(GIA_rVect_old(3,12,mesh_maxNips,mesh_NcpElems)) ; GIA_rVect_old = 0.0_pReal
allocate(GIA_bNorm(3,12)) ; GIA_bNorm = 0.0_pReal
do b = 1,4
GIA_bNorm(1,b) = 1.0_pReal
GIA_bNorm(2,b+4) = 1.0_pReal
GIA_bNorm(3,b+8) = 1.0_pReal
enddo
!
! *** Output to MARC output file ***
!$OMP CRITICAL (write2out)
write(6,*)
write(6,*) 'CPFEM Initialization'
write(6,*)
write(6,*) 'CPFEM_Temperature: ', shape(CPFEM_Temperature)
write(6,*) 'CPFEM_ffn_bar: ', shape(CPFEM_ffn_bar)
write(6,*) 'CPFEM_ffn1_bar: ', shape(CPFEM_ffn1_bar)
write(6,*) 'CPFEM_PK1_bar: ', shape(CPFEM_PK1_bar)
write(6,*) 'CPFEM_dPdF_bar: ', shape(CPFEM_dPdF_bar)
write(6,*) 'CPFEM_stress_bar: ', shape(CPFEM_stress_bar)
write(6,*) 'CPFEM_jaco_bar: ', shape(CPFEM_jaco_bar)
write(6,*) 'CPFEM_jaco_knownGood: ', shape(CPFEM_jaco_knownGood)
write(6,*) 'CPFEM_results: ', shape(CPFEM_results)
write(6,*) 'CPFEM_Fp_old: ', shape(CPFEM_Fp_old)
write(6,*) 'CPFEM_Fp_new: ', shape(CPFEM_Fp_new)
!
write(6,*) 'GIA_rVect_new: ', shape(GIA_rVect_new)
write(6,*) 'GIA_rVect_old: ', shape(GIA_rVect_old)
write(6,*) 'GIA_bNorm: ', shape(GIA_bNorm)
write(6,*)
call flush(6)
!$OMP END CRITICAL (write2out)
return
!
END SUBROUTINE
!
!
!***********************************************************************
!*** perform initialization at first call, update variables and ***
!*** call the actual material model ***
!
! CPFEM_mode computation mode (regular, collection, recycle)
! ffn deformation gradient for t=t0
! ffn1 deformation gradient for t=t1
! Temperature temperature
! CPFEM_dt time increment
! CPFEM_en element number
! CPFEM_in intergration point number
! CPFEM_stress stress vector in Mandel notation
! CPFEM_updateJaco flag to initiate computation of Jacobian
! CPFEM_jaco jacobian in Mandel notation
! CPFEM_ngens size of stress strain law
!***********************************************************************
SUBROUTINE CPFEM_general(CPFEM_mode, ffn, ffn1, Temperature, CPFEM_dt,&
CPFEM_en, CPFEM_in, CPFEM_stress, CPFEM_updateJaco, CPFEM_jaco, CPFEM_ngens)
! note: CPFEM_stress = Cauchy stress cs(6) and CPFEM_jaco = Consistent tangent dcs/de
!
use prec, only: pReal,pInt
use FEsolving
use debug
use math
use mesh, only: mesh_init,mesh_FEasCP, mesh_NcpElems, FE_Nips, FE_mapElemtype, mesh_element
use lattice, only: lattice_init
use constitutive, only: constitutive_init,constitutive_state_old,constitutive_state_new,material_Cslip_66
implicit none
!
integer(pInt) CPFEM_en, CPFEM_in, cp_en, CPFEM_ngens, i,j,k,l,m,n, e
real(pReal), dimension (3,3) :: ffn,ffn1,Kirchhoff_bar
real(pReal), dimension (3,3,3,3) :: H_bar, H_bar_sym
real(pReal), dimension(CPFEM_ngens) :: CPFEM_stress
real(pReal), dimension(CPFEM_ngens,CPFEM_ngens) :: CPFEM_jaco
real(pReal) Temperature,CPFEM_dt,J_inverse
integer(pInt) CPFEM_mode ! 1: regular computation with aged results&
! 2: regular computation&
! 3: collection of FEM data&
! 4: recycling of former results (MARC speciality)&
! 5: record tangent from former converged inc&
! 6: restore tangent from former converged inc
logical CPFEM_updateJaco
!
if (.not. CPFEM_init_done) then ! initialization step (three dimensional stress state check missing?)
call math_init()
call mesh_init()
call lattice_init()
call constitutive_init()
call CPFEM_init(Temperature)
CPFEM_init_done = .true.
endif
!
cp_en = mesh_FEasCP('elem',CPFEM_en)
if (cp_en == 1 .and. CPFEM_in == 1) then
!$OMP CRITICAL (write2out)
write(6,'(a6,x,i4,x,a4,x,i4,x,a10,x,f8.4,x,a10,x,i2,x,a10,x,i2,x,a10,x,i2,x,a10,x,i2)') &
'elem',cp_en,'IP',CPFEM_in,&
'theTime',theTime,'theInc',theInc,'theCycle',theCycle,'theLovl',theLovl,&
'mode',CPFEM_mode
!$OMP END CRITICAL (write2out)
endif
!
select case (CPFEM_mode)
case (2,1) ! regular computation (with aging of results)
if (.not. CPFEM_calc_done) then ! puuh, me needs doing all the work...
!$OMP CRITICAL (write2out)
write (6,*) 'puuh me needs doing all the work', cp_en
!$OMP END CRITICAL (write2out)
if (CPFEM_mode == 1) then ! age results at start of new increment
CPFEM_Fp_old = CPFEM_Fp_new
constitutive_state_old = constitutive_state_new
GIA_rVect_old = GIA_rVect_new
!$OMP CRITICAL (write2out)
write (6,*) '#### aged results'
!$OMP END CRITICAL (write2out)
endif
debug_cutbackDistribution = 0_pInt ! initialize debugging data
debug_InnerLoopDistribution = 0_pInt
debug_OuterLoopDistribution = 0_pInt
!
do e=1,mesh_NcpElems ! ## this shall be done in a parallel loop in the future ##
do i=1,FE_Nips(mesh_element(2,e)) ! iterate over all IPs of this element's type
debugger = (e==1 .and. i==1) ! switch on debugging for first IP in first element
call CPFEM_MaterialPoint(CPFEM_updateJaco, CPFEM_dt, i, e)
enddo
enddo
call debug_info() ! output of debugging/performance statistics
CPFEM_calc_done = .true. ! now calc is done
endif
! translate from P and dP/dF to CS and dCS/dE
!!$OMP CRITICAL (evilmatmul)
Kirchhoff_bar = math_mul33x33(CPFEM_PK1_bar(:,:,CPFEM_in, cp_en),transpose(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en)))
!!$OMP END CRITICAL (evilmatmul)
J_inverse = 1.0_pReal/math_det3x3(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en))
CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel33to6(J_inverse*Kirchhoff_bar)
!
H_bar = 0.0_pReal
forall(i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
H_bar(i,j,k,l) = H_bar(i,j,k,l) + &
(CPFEM_ffn1_bar(j,m,CPFEM_in,cp_en)*CPFEM_ffn1_bar(l,n,CPFEM_in,cp_en)*CPFEM_dPdF_bar(i,m,k,n,CPFEM_in,cp_en) - &
math_I3(j,l)*CPFEM_ffn1_bar(i,m,CPFEM_in,cp_en)*CPFEM_PK1_bar(k,m,CPFEM_in,cp_en)) + &
0.5_pReal*(math_I3(i,k)*Kirchhoff_bar(j,l) + math_I3(j,l)*Kirchhoff_bar(i,k) + &
math_I3(i,l)*Kirchhoff_bar(j,k) + math_I3(j,k)*Kirchhoff_bar(i,l))
forall(i=1:3,j=1:3,k=1:3,l=1:3) &
H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel3333to66(J_inverse*H_bar)
!
case (3) ! collect and return odd result
CPFEM_Temperature(CPFEM_in,cp_en) = Temperature
CPFEM_ffn_bar(:,:,CPFEM_in,cp_en) = ffn
CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) = ffn1
CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
CPFEM_calc_done = .false.
case (4) ! do nothing since we can recycle the former results (MARC specialty)
case (5) ! record consistent tangent at beginning of new increment
CPFEM_jaco_knownGood = CPFEM_jaco_bar
case (6) ! restore consistent tangent after cutback
CPFEM_jaco_bar = CPFEM_jaco_knownGood
end select
!
! return the local stress and the jacobian from storage
CPFEM_stress(1:CPFEM_ngens) = CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en)
CPFEM_jaco(1:CPFEM_ngens,1:CPFEM_ngens) = CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en)
! if (cp_en == 1 .and. CPFEM_in == 1) write (6,*) 'stress',CPFEM_stress
! if (cp_en == 1 .and. CPFEM_in == 1 .and. CPFEM_updateJaco) write (6,*) 'stiffness',CPFEM_jaco
! if (cp_en == 1 .and. CPFEM_in == 1) write (6,*) 'vector',GIA_rVect_new(:,:,1,1)
!
return
!
END SUBROUTINE
!
!**********************************************************
!*** calculate the material point behaviour ***
!**********************************************************
SUBROUTINE CPFEM_MaterialPoint(&
updateJaco,& ! flag to initiate Jacobian updating
CPFEM_dt,& ! Time increment (dt)
CPFEM_in,& ! Integration point number
cp_en) ! Element number
!
use prec
use FEsolving, only: theCycle
use debug
use math, only: math_pDecomposition,math_RtoEuler,inDeg,math_I3,math_invert3x3,math_permut,math_invert,math_delta
use IO, only: IO_error
use mesh, only: mesh_element
use crystallite
use constitutive
implicit none
!
character(len=128) msg
integer(pInt) cp_en,CPFEM_in,grain,max_cutbacks,i,j,k,l,m,n,iBoun,NRiter,dummy,ii,jj,kk,ll,ip,jp
logical updateJaco,error,NRconvergent,failed
real(pReal) CPFEM_dt,volfrac,dTime,shMod,C_kb,resNorm,resMax,subStep,subFrac,temp1,temp2
real(pReal), dimension(3,3) :: F0_bar,F1_bar,dF_bar,PK1_per,F1_per
real(pReal), dimension(3,3) :: U,R
real(pReal), dimension(3,3,8) :: PK1,Fp0,Fp1,Fe1,F1,F0
real(pReal), dimension(3,3,12) :: GPK1,GF1,Nye,GRB1
real(pReal), dimension(3,3,3,3,8) :: dPdF
real(pReal), dimension(3,3,3,3,12) :: dRdX1
real(pReal), dimension(36) :: var,res
real(pReal), dimension(36,36) :: dresdvar,dvardres
real(pReal), dimension(3,12) :: rx,rVect
real(pReal), dimension(12) :: NyeNorm
real(pReal), dimension(constitutive_maxNstatevars,8) :: state0,state1
!
if (texture_Ngrains(mesh_element(4,cp_en)) /= 8_pInt) then
call IO_error(800)
return
endif
!
CPFEM_PK1_bar(:,:,CPFEM_in,cp_en) = 0.0_pReal ! zero out average first PK stress
if (updateJaco) CPFEM_dPdF_bar(:,:,:,:,CPFEM_in,cp_en) = 0.0_pReal ! zero out average consistent tangent
!
! ------------- GIA loop --------------------
!
! collect information
shMod = 0.2_pReal*(material_C11(1) - material_C12(1)) + 0.3_pReal*material_C44(1) ! equivalent shear modulus
C_kb = material_bg(1)*shMod/material_GrainSize(1) ! equivalent boundary stiffness
!
F0_bar = CPFEM_ffn_bar(:,:,CPFEM_in,cp_en) ! effective deformation gradient at t_n
state0 = constitutive_state_old(:,:,CPFEM_in,cp_en) ! state variables at t_n
Fp0 = CPFEM_Fp_old(:,:,:,CPFEM_in,cp_en) ! grain plastic def. gradient at t_n
rVect = GIA_rVect_old(:,:,CPFEM_in,cp_en) ! relaxation vectors from previous convergent step
!
dF_bar = CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) - CPFEM_ffn_bar(:,:,CPFEM_in,cp_en) ! deformation gradient increment
subFrac = 0.0_pReal
subStep = 1.0_pReal
!
! Substepping procedure to improve N-R iteration
SubStepping: do
dTime = subStep*CPFEM_dt
call GIA_RelaxedDeformation(F0,F0_bar,rVect) ! def. gradient of indiv. grains at t_n
F1_bar = F0_bar + subStep*dF_bar ! effective def. gradient at t_n+1
forall (iBoun=1:12,i=1:3) var(3_pInt*(iBoun-1_pInt)+i) = rVect(i,iBoun) ! primary variable: relaxation vector
!
! Newton-Raphson iteration block
NRiter = 1_pInt
NRIteration: do
forall (iBoun=1:12,i=1:3) rx(i,iBoun) = var(3_pInt*(iBoun-1_pInt)+i) ! relaxation vectors (guess)
!
! deformation gradients of grains at t_n+1 (guess)
call GIA_RelaxedDeformation(F1,F1_bar,rx)
!
! -------------- grain loop -----------------
do grain = 1,texture_Ngrains(mesh_element(4,cp_en))
call SingleCrystallite(msg,PK1(:,:,grain),dPdF(:,:,:,:,grain),&
CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
grain,CPFEM_in,cp_en),&
Fp1(:,:,grain),Fe1(:,:,grain),state1(:,grain),& ! output up to here
dTime,cp_en,CPFEM_in,grain,.true.,&
CPFEM_Temperature(CPFEM_in,cp_en),F1(:,:,grain),F0(:,:,grain),Fp0(:,:,grain),state0(:,grain))
if (msg /= 'ok') then ! solution not reached --> exit NRIteration
!$OMP CRITICAL (write2out)
write(6,*) 'GIA: grain loop failed to converge @ EL:',cp_en,' IP:',CPFEM_in
!$OMP END CRITICAL (write2out)
NRconvergent = .false.
exit NRiteration
endif
enddo ! grain loop
!
! calculate the deformation jump and stress jump across the boundaries
call GIA_BoundaryJump(GF1,F1)
call GIA_BoundaryJump(GPK1,PK1)
!
! compute the Nye tensor at the boundary
Nye = 0.0_pReal
NyeNorm = 0.0_pReal
do iBoun = 1,12
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
Nye(i,j,iBoun) = Nye(i,j,iBoun) - 0.5_pReal*math_permut(j,k,l)*GIA_bNorm(k,iBoun)*GF1(i,l,iBoun)
enddo
enddo
NyeNorm(iBoun) = NyeNorm(iBoun) + Nye(i,j,iBoun)*Nye(i,j,iBoun)
enddo
enddo
NyeNorm(iBoun) = sqrt(NyeNorm(iBoun))
if (NyeNorm(iBoun) > 1.0e-8_pReal) Nye(:,:,iBoun) = Nye(:,:,iBoun)/NyeNorm(iBoun)
enddo
!
! compute the stress-like penalty at the boundary
GRB1 = 0.0_pReal
do iBoun = 1,12
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
GRB1(i,j,iBoun) = GRB1(i,j,iBoun) + Nye(i,k,iBoun)*GIA_bNorm(l,iBoun)*math_permut(k,l,j)
enddo
enddo
enddo
enddo
GRB1(:,:,iBoun) = 0.5_pReal*(C_kb + C_kb)*GRB1(:,:,iBoun)
enddo
!
! compute the resiudal of stress at the boundary
res = 0.0_pReal
resNorm = 0.0_pReal
do iBoun = 1,12
do j = 1,3
do i = 1,3
res(3_pInt*(iBoun-1_pInt)+j) = res(3_pInt*(iBoun-1_pInt)+j) - &
GIA_bNorm(i,iBoun)*(GPK1(i,j,iBoun) - GRB1(i,j,iBoun))
enddo
resNorm = resNorm + res(3_pInt*(iBoun-1_pInt)+j)*res(3_pInt*(iBoun-1_pInt)+j)
enddo
enddo
resNorm = sqrt(resNorm)
!
if (debugger) then
!$OMP CRITICAL (write2out)
write(6,'(x,a,i3,a,i3,a,i3,a,e10.4)')'EL:',cp_en,' IP:',CPFEM_in,' Iter:',NRiter,' RNorm:',resNorm
!$OMP END CRITICAL (write2out)
if (NRiter == 1_pInt) resMax = resNorm
if ((resNorm < resToler*resMax) .or. (resNorm < resAbsol)) then ! resNorm < tolerance ===> convergent
NRconvergent = .true.
exit NRiteration
elseif ((NRiter > NRiterMax) .or. (resNorm > resBound*resMax)) then ! resNorm > up. bound ===> substepping
NRconvergent = .false.
exit NRiteration
else ! update the residual
dRdX1 = 0.0_pReal
do iBoun = 1,12
if (NyeNorm(iBoun) < 1.0e-8_pReal) NyeNorm(iBoun) = 1.0e-8_pReal
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
temp1 = 0.0_pReal
temp2 = 0.0_pReal
do ii = 1,3
do jj = 1,3
do kk = 1,3
temp1 = temp1 + GIA_bNorm(jj,iBoun)*math_permut(ii,jj,j)*math_delta(i,k)* &
GIA_bNorm(kk,iBoun)*math_permut(ii,kk,l)
do ll = 1,3
temp2 = temp2 + Nye(i,ii,iBoun)*GIA_bNorm(jj,iBoun)*math_permut(ii,jj,j)* &
Nye(k,kk,iBoun)*GIA_bNorm(ll,iBoun)*math_permut(kk,ll,l)
enddo
enddo
enddo
enddo
dRdX1(i,j,k,l,iBoun) = 0.25_pReal*(C_kb + C_kb)*(temp1 - temp2)/NyeNorm(iBoun)
enddo
enddo
enddo
enddo
enddo
call GIA_JacobianMatrix(dresdvar,dPdF,dRdX1)
dvardres = 0.0_pReal
call math_invert(36,dresdvar,dvardres,dummy,failed)
if (failed) then
!$OMP CRITICAL (write2out)
write(6,*) 'GIA: failed to invert the Jacobian @ EL:',cp_en,' IP:',CPFEM_in
!$OMP END CRITICAL (write2out)
NRconvergent = .false.
exit NRiteration
endif
forall (i=1:36,j=1:36) var(i) = var(i) - dvardres(i,j)*res(j)
endif
!
NRiter = NRiter + 1_pInt
enddo NRIteration ! End of N-R iteration blok
!
if (.not. NRconvergent) then
subStep = 0.5_pReal*subStep
else
subFrac = subFrac + subStep
subStep = 1.0_pReal - subFrac
Fp0 = Fp1
F0_bar = F1_bar
state0 = state1
rVect = rx
endif
!
if (subStep < subStepMin) exit SubStepping
enddo SubStepping ! End of substepping blok
!
! ------------- GIA loop (end) --------------
!
! return to the general subroutine when convergence is not reached
if (.not. NRconvergent) then
!$OMP CRITICAL (write2out)
write(6,'(x,a)') 'GIA: convergence is not reached @ EL:',cp_en,' IP:',CPFEM_in
!$OMP END CRITICAL (write2out)
call IO_error(600)
return
endif
!
! updates all variables, deformation gradients, and vectors
GIA_rVect_new(:,:,CPFEM_in,cp_en) = rVect
CPFEM_Fp_new(:,:,:,CPFEM_in,cp_en) = Fp1
constitutive_state_new(:,:,CPFEM_in,cp_en) = state1
!
! compute the effective stress and consistent tangent
do grain = 1,texture_Ngrains(mesh_element(4,cp_en))
volfrac = constitutive_matVolFrac(grain,CPFEM_in,cp_en)*constitutive_texVolFrac(grain,CPFEM_in,cp_en)
CPFEM_PK1_bar(:,:,CPFEM_in,cp_en) = CPFEM_PK1_bar(:,:,CPFEM_in,cp_en) + &
volfrac*PK1(:,:,grain) ! average Cauchy stress
!
! update results plotted in MENTAT
call math_pDecomposition(Fe1(:,:,grain),U,R,error) ! polar decomposition
if (error) then
!$OMP CRITICAL (write2out)
write(6,*) Fe1(:,:,grain)
write(6,*) 'polar decomposition'
write(6,*) 'Grain: ',grain
write(6,*) 'Integration point: ',CPFEM_in
write(6,*) 'Element: ',mesh_element(1,cp_en)
!$OMP END CRITICAL (write2out)
call IO_error(650)
return
endif
CPFEM_results(1:3,grain,CPFEM_in,cp_en) = math_RtoEuler(transpose(R))*inDeg ! orientation
CPFEM_results(4 ,grain,CPFEM_in,cp_en) = volfrac ! volume fraction of orientation
enddo
!
if (theCycle >= 0_pInt) then
forall (grain=1:texture_Ngrains(mesh_element(4,cp_en))) &
CPFEM_dPdF_bar(:,:,:,:,CPFEM_in,cp_en) = CPFEM_dPdF_bar(:,:,:,:,CPFEM_in,cp_en) + volfrac*dPdF(:,:,:,:,grain)
else
do ip = 1,3
do jp = 1,3
F1_per = F1_bar
F1_per(ip,jp) = F1_per(ip,jp) + 1.0e-5_pReal
forall (iBoun=1:12,i=1:3) var(3_pInt*(iBoun-1_pInt)+i) = rVect(i,iBoun)
NRiter = 1_pInt
!
NRPerturbation: do
forall (iBoun=1:12,i=1:3) rx(i,iBoun) = var(3_pInt*(iBoun-1_pInt)+i) ! relaxation vectors (guess)
call GIA_RelaxedDeformation(F1,F1_bar,rx)
do grain = 1,8
call SingleCrystallite(msg,PK1(:,:,grain),dPdF(:,:,:,:,grain),&
CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
grain,CPFEM_in,cp_en),&
Fp1(:,:,grain),Fe1(:,:,grain),state1(:,grain),& ! output up to here
dTime,cp_en,CPFEM_in,grain,.true.,&
CPFEM_Temperature(CPFEM_in,cp_en),F1(:,:,grain),F0(:,:,grain),Fp0(:,:,grain),state0(:,grain))
if (msg /= 'ok') then ! solution not reached --> exit NRIteration
!$OMP CRITICAL (write2out)
write(6,*) 'GIA: perturbation grain loop failed to converge within allowable step-size'
!$OMP END CRITICAL (write2out)
NRconvergent = .false.
exit NRPerturbation
endif
enddo
call GIA_BoundaryJump(GF1,F1)
call GIA_BoundaryJump(GPK1,PK1)
!
Nye = 0.0_pReal
NyeNorm = 0.0_pReal
do iBoun = 1,12
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
Nye(i,j,iBoun) = Nye(i,j,iBoun) - 0.5_pReal*math_permut(j,k,l)*GIA_bNorm(k,iBoun)*GF1(i,l,iBoun)
enddo
enddo
NyeNorm(iBoun) = NyeNorm(iBoun) + Nye(i,j,iBoun)*Nye(i,j,iBoun)
enddo
enddo
NyeNorm(iBoun) = sqrt(NyeNorm(iBoun))
if (NyeNorm(iBoun) > 1.0e-8_pReal) Nye(:,:,iBoun) = Nye(:,:,iBoun)/NyeNorm(iBoun)
enddo
!
GRB1 = 0.0_pReal
do iBoun = 1,12
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
GRB1(i,j,iBoun) = GRB1(i,j,iBoun) + Nye(i,k,iBoun)*GIA_bNorm(l,iBoun)*math_permut(k,l,j)
enddo
enddo
enddo
enddo
GRB1(:,:,iBoun) = 0.5_pReal*(C_kb + C_kb)*GRB1(:,:,iBoun)
enddo
!
res = 0.0_pReal
resNorm = 0.0_pReal
do iBoun = 1,12
do j = 1,3
do i = 1,3
res(3_pInt*(iBoun-1_pInt)+j) = res(3_pInt*(iBoun-1_pInt)+j) - &
GIA_bNorm(i,iBoun)*(GPK1(i,j,iBoun) - GRB1(i,j,iBoun))
enddo
resNorm = resNorm + res(3_pInt*(iBoun-1_pInt)+j)*res(3_pInt*(iBoun-1_pInt)+j)
enddo
enddo
resNorm = sqrt(resNorm)
!
! if (debugger) then
!!$OMP CRITICAL (write2out)
! write(6,'(x,a,i3,a,i3,a,i3,a,i3,a,e10.4)')'EL = ',cp_en,':IP = ',CPFEM_in,':pert = ',3*(ip-1)+jp,':Iter = ',NRiter,':RNorm = ',resNorm
!!$OMP END CRITICAL (write2out)
! endif
if (NRiter == 1_pInt) resMax = resNorm
if ((resNorm < resToler*resMax) .or. (resNorm < resAbsol)) then ! resNorm < tolerance ===> convergent
NRconvergent = .true.
exit NRPerturbation
elseif ((NRiter > NRiterMax) .or. (resNorm > resBound*resMax)) then ! resNorm > up. bound ===> substepping
NRconvergent = .false.
exit NRPerturbation
else ! update the residual
dRdX1 = 0.0_pReal
do iBoun = 1,12
if (NyeNorm(iBoun) < 1.0e-8_pReal) NyeNorm(iBoun) = 1.0e-8_pReal
do i = 1,3
do j = 1,3
do k = 1,3
do l = 1,3
temp1 = 0.0_pReal
temp2 = 0.0_pReal
do ii = 1,3
do jj = 1,3
do kk = 1,3
temp1 = temp1 + GIA_bNorm(jj,iBoun)*math_permut(ii,jj,j)*math_delta(i,k)* &
GIA_bNorm(kk,iBoun)*math_permut(ii,kk,l)
do ll = 1,3
temp2 = temp2 + Nye(i,ii,iBoun)*GIA_bNorm(jj,iBoun)*math_permut(ii,jj,j)* &
Nye(k,kk,iBoun)*GIA_bNorm(ll,iBoun)*math_permut(kk,ll,l)
enddo
enddo
enddo
enddo
dRdX1(i,j,k,l,iBoun) = 0.25_pReal*(C_kb + C_kb)*(temp1 - temp2)/NyeNorm(iBoun)
enddo
enddo
enddo
enddo
enddo
call GIA_JacobianMatrix(dresdvar,dPdF,dRdX1)
dvardres = 0.0_pReal
call math_invert(36,dresdvar,dvardres,dummy,failed)
if (failed) then
!$OMP CRITICAL (write2out)
write(6,*) 'GIA: perturbation failed to invert the Jacobian'
!$OMP END CRITICAL (write2out)
NRconvergent = .false.
exit NRPerturbation
endif
forall (i=1:36,j=1:36) var(i) = var(i) - dvardres(i,j)*res(j)
endif
NRiter = NRiter + 1_pInt
enddo NRPerturbation ! End of N-R iteration blok
!
PK1_per = 0.0_pReal
do grain = 1,texture_Ngrains(mesh_element(4,cp_en))
volfrac = constitutive_matVolFrac(grain,CPFEM_in,cp_en)*constitutive_texVolFrac(grain,CPFEM_in,cp_en)
PK1_per = PK1_per + volfrac*PK1(:,:,grain)
enddo
CPFEM_dPdF_bar(:,:,ip,jp,CPFEM_in,cp_en) = (PK1_per - CPFEM_PK1_bar(:,:,CPFEM_in,cp_en))/1.0e-5_pReal
enddo
enddo
endif
!
return
!
END SUBROUTINE
!
!
!********************************************************************
! Calculates the relaxed deformation gradients of grains
!********************************************************************
subroutine GIA_RelaxedDeformation(&
F,& ! relaxed deformation gradient of grains
F_bar,& ! effective deformation gradient
r) ! relaxation vectors at boundary
!
implicit none
!
real(pReal), dimension(3,3) :: F_bar
real(pReal), dimension(3,3,8) :: F
real(pReal), dimension(3,12) :: r,n
integer(pInt) i,j,iBoun,grain
!
n = GIA_bNorm
do i = 1,3
do j = 1,3
F(i,j,1) = F_bar(i,j) + n(i, 1)*r(j, 1) + n(i, 5)*r(j, 5) + n(i, 9)*r(j, 9)
F(i,j,2) = F_bar(i,j) - n(i, 1)*r(j, 1) + n(i, 6)*r(j, 6) + n(i,10)*r(j,10)
F(i,j,3) = F_bar(i,j) + n(i, 2)*r(j, 2) - n(i, 5)*r(j, 5) + n(i,11)*r(j,11)
F(i,j,4) = F_bar(i,j) - n(i, 2)*r(j, 2) - n(i, 6)*r(j, 6) + n(i,12)*r(j,12)
F(i,j,5) = F_bar(i,j) + n(i, 3)*r(j, 3) + n(i, 7)*r(j, 7) - n(i, 9)*r(j, 9)
F(i,j,6) = F_bar(i,j) - n(i, 3)*r(j, 3) + n(i, 8)*r(j, 8) - n(i,10)*r(j,10)
F(i,j,7) = F_bar(i,j) + n(i, 4)*r(j, 4) - n(i, 7)*r(j, 7) - n(i,11)*r(j,11)
F(i,j,8) = F_bar(i,j) - n(i, 4)*r(j, 4) - n(i, 8)*r(j, 8) - n(i,12)*r(j,12)
enddo
enddo
!
return
!
END SUBROUTINE
!
!
!********************************************************************
! Calculates the jump of tensors across the grain boundary
!********************************************************************
subroutine GIA_BoundaryJump(&
F_boun,& ! tensor jump across the boundary
F_bulk) ! bulk tensor
!
implicit none
!
real(pReal), dimension(3,3,12) :: F_boun
real(pReal), dimension(3,3,8) :: F_bulk
integer(pInt) i,j,iBoun,grain
!
F_boun(:,:, 1) = F_bulk(:,:,2) - F_bulk(:,:,1)
F_boun(:,:, 2) = F_bulk(:,:,4) - F_bulk(:,:,3)
F_boun(:,:, 3) = F_bulk(:,:,6) - F_bulk(:,:,5)
F_boun(:,:, 4) = F_bulk(:,:,8) - F_bulk(:,:,7)
F_boun(:,:, 5) = F_bulk(:,:,3) - F_bulk(:,:,1)
F_boun(:,:, 6) = F_bulk(:,:,4) - F_bulk(:,:,2)
F_boun(:,:, 7) = F_bulk(:,:,7) - F_bulk(:,:,5)
F_boun(:,:, 8) = F_bulk(:,:,8) - F_bulk(:,:,6)
F_boun(:,:, 9) = F_bulk(:,:,5) - F_bulk(:,:,1)
F_boun(:,:,10) = F_bulk(:,:,6) - F_bulk(:,:,2)
F_boun(:,:,11) = F_bulk(:,:,7) - F_bulk(:,:,3)
F_boun(:,:,12) = F_bulk(:,:,8) - F_bulk(:,:,4)
!
return
!
END SUBROUTINE
!
!
!********************************************************************
! Calculates the jump of tensors across the grain boundary
!********************************************************************
subroutine GIA_JacobianMatrix(&
dresdvar,& ! Jacobian matrix
dPdF,& ! stress consistent tangent of bulk
dRdX) ! stress-like penalty tangent at boundary
!
implicit none
!
real(pReal), dimension(3,3,3,3,8) :: dPdF
real(pReal), dimension(3,3,3,3,12) :: dRdX
real(pReal), dimension(36,36) :: dresdvar
real(pReal), dimension(3,12) :: n
integer(pInt) i,j,k,l
!
n = GIA_bNorm
dresdvar = 0.0_pReal
do i = 1,3
do k = 1,3
do l = 1,3
do j = 1,3
!
! at boundary 1, influenced by boundary +5, -6, +9, -10
dresdvar(( 1-1)*3 + j,( 1-1)*3 + l) = dresdvar(( 1-1)*3 + j,( 1-1)*3 + l) &
+ (dPdF(i,j,k,l, 1) + dPdF(i,j,k,l, 2))*n(i, 1)*n(k, 1) &
+ (dRdX(i,j,k,l, 1) + dRdX(i,j,k,l, 1))*n(i, 1)*n(k, 1)
dresdvar(( 1-1)*3 + j,( 5-1)*3 + l) = dresdvar(( 1-1)*3 + j,( 5-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 1)*n(k, 5) &
+ dRdX(i,j,k,l, 1)*n(i, 1)*n(k, 5)
dresdvar(( 1-1)*3 + j,( 6-1)*3 + l) = dresdvar(( 1-1)*3 + j,( 6-1)*3 + l) - dPdF(i,j,k,l, 2)*n(i, 1)*n(k, 6) &
- dRdX(i,j,k,l, 1)*n(i, 1)*n(k, 6)
dresdvar(( 1-1)*3 + j,( 9-1)*3 + l) = dresdvar(( 1-1)*3 + j,( 9-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 1)*n(k, 9) &
+ dRdX(i,j,k,l, 1)*n(i, 1)*n(k, 9)
dresdvar(( 1-1)*3 + j,(10-1)*3 + l) = dresdvar(( 1-1)*3 + j,(10-1)*3 + l) - dPdF(i,j,k,l, 2)*n(i, 1)*n(k,10) &
- dRdX(i,j,k,l, 1)*n(i, 1)*n(k,10)
!
! at boundary 2, influenced by boundary -5, +6, +11, -12
dresdvar(( 2-1)*3 + j,( 2-1)*3 + l) = dresdvar(( 2-1)*3 + j,( 2-1)*3 + l) &
+ (dPdF(i,j,k,l, 3) + dPdF(i,j,k,l, 4))*n(i, 2)*n(k, 2) &
+ (dRdX(i,j,k,l, 2) + dRdX(i,j,k,l, 2))*n(i, 2)*n(k, 2)
dresdvar(( 2-1)*3 + j,( 5-1)*3 + l) = dresdvar(( 2-1)*3 + j,( 5-1)*3 + l) - dPdF(i,j,k,l, 3)*n(i, 2)*n(k, 5) &
- dRdX(i,j,k,l, 2)*n(i, 2)*n(k, 5)
dresdvar(( 2-1)*3 + j,( 6-1)*3 + l) = dresdvar(( 2-1)*3 + j,( 6-1)*3 + l) + dPdF(i,j,k,l, 4)*n(i, 2)*n(k, 6) &
+ dRdX(i,j,k,l, 2)*n(i, 2)*n(k, 6)
dresdvar(( 2-1)*3 + j,(11-1)*3 + l) = dresdvar(( 2-1)*3 + j,(11-1)*3 + l) + dPdF(i,j,k,l, 3)*n(i, 2)*n(k,11) &
+ dRdX(i,j,k,l, 2)*n(i, 2)*n(k,11)
dresdvar(( 2-1)*3 + j,(12-1)*3 + l) = dresdvar(( 2-1)*3 + j,(12-1)*3 + l) - dPdF(i,j,k,l, 4)*n(i, 2)*n(k,12) &
- dRdX(i,j,k,l, 2)*n(i, 2)*n(k,12)
!
! at boundary 3, influenced by boundary +7, -8, -9, +10
dresdvar(( 3-1)*3 + j,( 3-1)*3 + l) = dresdvar(( 3-1)*3 + j,( 3-1)*3 + l) &
+ (dPdF(i,j,k,l, 5) + dPdF(i,j,k,l, 6))*n(i, 3)*n(k, 3) &
+ (dRdX(i,j,k,l, 3) + dRdX(i,j,k,l, 3))*n(i, 3)*n(k, 3)
dresdvar(( 3-1)*3 + j,( 7-1)*3 + l) = dresdvar(( 3-1)*3 + j,( 7-1)*3 + l) + dPdF(i,j,k,l, 5)*n(i, 3)*n(k, 7) &
+ dRdX(i,j,k,l, 3)*n(i, 3)*n(k, 7)
dresdvar(( 3-1)*3 + j,( 8-1)*3 + l) = dresdvar(( 3-1)*3 + j,( 8-1)*3 + l) - dPdF(i,j,k,l, 6)*n(i, 3)*n(k, 8) &
- dRdX(i,j,k,l, 3)*n(i, 3)*n(k, 8)
dresdvar(( 3-1)*3 + j,( 9-1)*3 + l) = dresdvar(( 3-1)*3 + j,( 9-1)*3 + l) - dPdF(i,j,k,l, 5)*n(i, 3)*n(k, 9) &
- dRdX(i,j,k,l, 3)*n(i, 3)*n(k, 9)
dresdvar(( 3-1)*3 + j,(10-1)*3 + l) = dresdvar(( 3-1)*3 + j,(10-1)*3 + l) + dPdF(i,j,k,l, 6)*n(i, 3)*n(k,10) &
+ dRdX(i,j,k,l, 3)*n(i, 3)*n(k,10)
!
! at boundary 4, influenced by boundary -7, +8, -11, +12
dresdvar(( 4-1)*3 + j,( 4-1)*3 + l) = dresdvar(( 4-1)*3 + j,( 4-1)*3 + l) &
+ (dPdF(i,j,k,l, 7) + dPdF(i,j,k,l, 8))*n(i, 4)*n(k, 4) &
+ (dRdX(i,j,k,l, 4) + dRdX(i,j,k,l, 4))*n(i, 4)*n(k, 4)
dresdvar(( 4-1)*3 + j,( 7-1)*3 + l) = dresdvar(( 4-1)*3 + j,( 7-1)*3 + l) - dPdF(i,j,k,l, 7)*n(i, 4)*n(k, 7) &
- dRdX(i,j,k,l, 4)*n(i, 4)*n(k, 7)
dresdvar(( 4-1)*3 + j,( 8-1)*3 + l) = dresdvar(( 4-1)*3 + j,( 8-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i, 4)*n(k, 8) &
+ dRdX(i,j,k,l, 4)*n(i, 4)*n(k, 8)
dresdvar(( 4-1)*3 + j,(11-1)*3 + l) = dresdvar(( 4-1)*3 + j,(11-1)*3 + l) - dPdF(i,j,k,l, 7)*n(i, 4)*n(k,11) &
- dRdX(i,j,k,l, 4)*n(i, 4)*n(k,11)
dresdvar(( 4-1)*3 + j,(12-1)*3 + l) = dresdvar(( 4-1)*3 + j,(12-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i, 4)*n(k,12) &
+ dRdX(i,j,k,l, 4)*n(i, 4)*n(k,12)
!
! at boundary 5, influenced by boundary +1, -2, +9, -11
dresdvar(( 5-1)*3 + j,( 5-1)*3 + l) = dresdvar(( 5-1)*3 + j,( 5-1)*3 + l) &
+ (dPdF(i,j,k,l, 1) + dPdF(i,j,k,l, 3))*n(i, 5)*n(k, 5) &
+ (dRdX(i,j,k,l, 5) + dRdX(i,j,k,l, 5))*n(i, 5)*n(k, 5)
dresdvar(( 5-1)*3 + j,( 1-1)*3 + l) = dresdvar(( 5-1)*3 + j,( 1-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 5)*n(k, 1) &
+ dRdX(i,j,k,l, 5)*n(i, 5)*n(k, 1)
dresdvar(( 5-1)*3 + j,( 2-1)*3 + l) = dresdvar(( 5-1)*3 + j,( 2-1)*3 + l) - dPdF(i,j,k,l, 3)*n(i, 5)*n(k, 2) &
- dRdX(i,j,k,l, 5)*n(i, 5)*n(k, 2)
dresdvar(( 5-1)*3 + j,( 9-1)*3 + l) = dresdvar(( 5-1)*3 + j,( 9-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 5)*n(k, 9) &
+ dRdX(i,j,k,l, 5)*n(i, 5)*n(k, 9)
dresdvar(( 5-1)*3 + j,(11-1)*3 + l) = dresdvar(( 5-1)*3 + j,(11-1)*3 + l) - dPdF(i,j,k,l, 3)*n(i, 5)*n(k,11) &
- dRdX(i,j,k,l, 5)*n(i, 5)*n(k,11)
!
! at boundary 6, influenced by boundary -1, +2, +10, -12
dresdvar(( 6-1)*3 + j,( 6-1)*3 + l) = dresdvar(( 6-1)*3 + j,( 6-1)*3 + l) &
+ (dPdF(i,j,k,l, 2) + dPdF(i,j,k,l, 4))*n(i, 6)*n(k, 6) &
+ (dRdX(i,j,k,l, 6) + dRdX(i,j,k,l, 6))*n(i, 6)*n(k, 6)
dresdvar(( 6-1)*3 + j,( 1-1)*3 + l) = dresdvar(( 6-1)*3 + j,( 1-1)*3 + l) - dPdF(i,j,k,l, 2)*n(i, 6)*n(k, 1) &
- dRdX(i,j,k,l, 6)*n(i, 6)*n(k, 1)
dresdvar(( 6-1)*3 + j,( 2-1)*3 + l) = dresdvar(( 6-1)*3 + j,( 2-1)*3 + l) + dPdF(i,j,k,l, 4)*n(i, 6)*n(k, 2) &
+ dRdX(i,j,k,l, 6)*n(i, 6)*n(k, 2)
dresdvar(( 6-1)*3 + j,(10-1)*3 + l) = dresdvar(( 6-1)*3 + j,(10-1)*3 + l) + dPdF(i,j,k,l, 2)*n(i, 6)*n(k,10) &
+ dRdX(i,j,k,l, 6)*n(i, 6)*n(k,10)
dresdvar(( 6-1)*3 + j,(12-1)*3 + l) = dresdvar(( 6-1)*3 + j,(12-1)*3 + l) - dPdF(i,j,k,l, 4)*n(i, 6)*n(k,12) &
- dRdX(i,j,k,l, 6)*n(i, 6)*n(k,12)
!
! at boundary 7, influenced by boundary +3, -4, -9, +11
dresdvar(( 7-1)*3 + j,( 7-1)*3 + l) = dresdvar(( 7-1)*3 + j,( 7-1)*3 + l) &
+ (dPdF(i,j,k,l, 5) + dPdF(i,j,k,l, 7))*n(i, 7)*n(k, 7) &
+ (dRdX(i,j,k,l, 7) + dRdX(i,j,k,l, 7))*n(i, 7)*n(k, 7)
dresdvar(( 7-1)*3 + j,( 3-1)*3 + l) = dresdvar(( 7-1)*3 + j,( 3-1)*3 + l) + dPdF(i,j,k,l, 5)*n(i, 7)*n(k, 3) &
+ dRdX(i,j,k,l, 7)*n(i, 7)*n(k, 3)
dresdvar(( 7-1)*3 + j,( 4-1)*3 + l) = dresdvar(( 7-1)*3 + j,( 4-1)*3 + l) - dPdF(i,j,k,l, 7)*n(i, 7)*n(k, 4) &
- dRdX(i,j,k,l, 7)*n(i, 7)*n(k, 4)
dresdvar(( 7-1)*3 + j,( 9-1)*3 + l) = dresdvar(( 7-1)*3 + j,( 9-1)*3 + l) - dPdF(i,j,k,l, 5)*n(i, 7)*n(k, 9) &
- dRdX(i,j,k,l, 7)*n(i, 7)*n(k, 9)
dresdvar(( 7-1)*3 + j,(11-1)*3 + l) = dresdvar(( 7-1)*3 + j,(11-1)*3 + l) + dPdF(i,j,k,l, 7)*n(i, 7)*n(k,11) &
+ dRdX(i,j,k,l, 7)*n(i, 7)*n(k,11)
!
! at boundary 8, influenced by boundary -3, +4, -10, +12
dresdvar(( 8-1)*3 + j,( 8-1)*3 + l) = dresdvar(( 8-1)*3 + j,( 8-1)*3 + l) &
+ (dPdF(i,j,k,l, 6) + dPdF(i,j,k,l, 8))*n(i, 8)*n(k, 8) &
+ (dRdX(i,j,k,l, 8) + dRdX(i,j,k,l, 8))*n(i, 8)*n(k, 8)
dresdvar(( 8-1)*3 + j,( 3-1)*3 + l) = dresdvar(( 8-1)*3 + j,( 3-1)*3 + l) - dPdF(i,j,k,l, 6)*n(i, 8)*n(k, 3) &
- dRdX(i,j,k,l, 8)*n(i, 8)*n(k, 3)
dresdvar(( 8-1)*3 + j,( 4-1)*3 + l) = dresdvar(( 8-1)*3 + j,( 4-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i, 8)*n(k, 4) &
+ dRdX(i,j,k,l, 8)*n(i, 8)*n(k, 4)
dresdvar(( 8-1)*3 + j,(10-1)*3 + l) = dresdvar(( 8-1)*3 + j,(10-1)*3 + l) - dPdF(i,j,k,l, 6)*n(i, 8)*n(k,10) &
- dRdX(i,j,k,l, 8)*n(i, 8)*n(k,10)
dresdvar(( 8-1)*3 + j,(12-1)*3 + l) = dresdvar(( 8-1)*3 + j,(12-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i, 8)*n(k,12) &
+ dRdX(i,j,k,l, 8)*n(i, 8)*n(k,12)
!
! at boundary 9, influenced by boundary +1, -3, +5, -7
dresdvar(( 9-1)*3 + j,( 9-1)*3 + l) = dresdvar(( 9-1)*3 + j,( 9-1)*3 + l) &
+ (dPdF(i,j,k,l, 1) + dPdF(i,j,k,l, 5))*n(i, 9)*n(k, 9) &
+ (dRdX(i,j,k,l, 9) + dRdX(i,j,k,l, 9))*n(i, 9)*n(k, 9)
dresdvar(( 9-1)*3 + j,( 1-1)*3 + l) = dresdvar(( 9-1)*3 + j,( 1-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 9)*n(k, 1) &
+ dRdX(i,j,k,l, 9)*n(i, 9)*n(k, 1)
dresdvar(( 9-1)*3 + j,( 3-1)*3 + l) = dresdvar(( 9-1)*3 + j,( 3-1)*3 + l) - dPdF(i,j,k,l, 5)*n(i, 9)*n(k, 3) &
- dRdX(i,j,k,l, 9)*n(i, 9)*n(k, 3)
dresdvar(( 9-1)*3 + j,( 5-1)*3 + l) = dresdvar(( 9-1)*3 + j,( 5-1)*3 + l) + dPdF(i,j,k,l, 1)*n(i, 9)*n(k, 5) &
+ dRdX(i,j,k,l, 9)*n(i, 9)*n(k, 5)
dresdvar(( 9-1)*3 + j,( 7-1)*3 + l) = dresdvar(( 9-1)*3 + j,( 7-1)*3 + l) - dPdF(i,j,k,l, 5)*n(i, 9)*n(k, 7) &
- dRdX(i,j,k,l, 9)*n(i, 9)*n(k, 7)
!
! at boundary 10, influenced by boundary -1, +3, +6, -8
dresdvar((10-1)*3 + j,(10-1)*3 + l) = dresdvar((10-1)*3 + j,(10-1)*3 + l) &
+ (dPdF(i,j,k,l, 2) + dPdF(i,j,k,l, 6))*n(i,10)*n(k,10) &
+ (dRdX(i,j,k,l,10) + dRdX(i,j,k,l,10))*n(i,10)*n(k,10)
dresdvar((10-1)*3 + j,( 1-1)*3 + l) = dresdvar((10-1)*3 + j,( 1-1)*3 + l) - dPdF(i,j,k,l, 2)*n(i,10)*n(k, 1) &
- dRdX(i,j,k,l,10)*n(i,10)*n(k, 1)
dresdvar((10-1)*3 + j,( 3-1)*3 + l) = dresdvar((10-1)*3 + j,( 3-1)*3 + l) + dPdF(i,j,k,l, 6)*n(i,10)*n(k, 3) &
+ dRdX(i,j,k,l,10)*n(i,10)*n(k, 3)
dresdvar((10-1)*3 + j,( 6-1)*3 + l) = dresdvar((10-1)*3 + j,( 6-1)*3 + l) + dPdF(i,j,k,l, 2)*n(i,10)*n(k, 6) &
+ dRdX(i,j,k,l,10)*n(i,10)*n(k, 6)
dresdvar((10-1)*3 + j,( 8-1)*3 + l) = dresdvar((10-1)*3 + j,( 8-1)*3 + l) - dPdF(i,j,k,l, 6)*n(i,10)*n(k, 8) &
- dRdX(i,j,k,l,10)*n(i,10)*n(k, 8)
!
! at boundary 11, influenced by boundary +2, -4, -5, +7
dresdvar((11-1)*3 + j,(11-1)*3 + l) = dresdvar((11-1)*3 + j,(11-1)*3 + l) &
+ (dPdF(i,j,k,l, 3) + dPdF(i,j,k,l, 7))*n(i,11)*n(k,11) &
+ (dRdX(i,j,k,l,11) + dRdX(i,j,k,l,11))*n(i,11)*n(k,11)
dresdvar((11-1)*3 + j,( 2-1)*3 + l) = dresdvar((11-1)*3 + j,( 2-1)*3 + l) + dPdF(i,j,k,l, 3)*n(i,11)*n(k, 2) &
+ dRdX(i,j,k,l,11)*n(i,11)*n(k, 2)
dresdvar((11-1)*3 + j,( 4-1)*3 + l) = dresdvar((11-1)*3 + j,( 4-1)*3 + l) - dPdF(i,j,k,l, 7)*n(i,11)*n(k, 4) &
- dRdX(i,j,k,l,11)*n(i,11)*n(k, 4)
dresdvar((11-1)*3 + j,( 5-1)*3 + l) = dresdvar((11-1)*3 + j,( 5-1)*3 + l) - dPdF(i,j,k,l, 3)*n(i,11)*n(k, 5) &
- dRdX(i,j,k,l,11)*n(i,11)*n(k, 5)
dresdvar((11-1)*3 + j,( 7-1)*3 + l) = dresdvar((11-1)*3 + j,( 7-1)*3 + l) + dPdF(i,j,k,l, 7)*n(i,11)*n(k, 7) &
+ dRdX(i,j,k,l,11)*n(i,11)*n(k, 7)
!
! at boundary 12, influenced by boundary -2, +4, -6, +8
dresdvar((12-1)*3 + j,(12-1)*3 + l) = dresdvar((12-1)*3 + j,(12-1)*3 + l) &
+ (dPdF(i,j,k,l, 4) + dPdF(i,j,k,l, 8))*n(i,12)*n(k,12) &
+ (dRdX(i,j,k,l,12) + dRdX(i,j,k,l,12))*n(i,12)*n(k,12)
dresdvar((12-1)*3 + j,( 2-1)*3 + l) = dresdvar((12-1)*3 + j,( 2-1)*3 + l) - dPdF(i,j,k,l, 4)*n(i,12)*n(k, 2) &
- dRdX(i,j,k,l,12)*n(i,12)*n(k, 2)
dresdvar((12-1)*3 + j,( 4-1)*3 + l) = dresdvar((12-1)*3 + j,( 4-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i,12)*n(k, 4) &
+ dRdX(i,j,k,l,12)*n(i,12)*n(k, 4)
dresdvar((12-1)*3 + j,( 6-1)*3 + l) = dresdvar((12-1)*3 + j,( 6-1)*3 + l) - dPdF(i,j,k,l, 4)*n(i,12)*n(k, 6) &
- dRdX(i,j,k,l,12)*n(i,12)*n(k, 6)
dresdvar((12-1)*3 + j,( 8-1)*3 + l) = dresdvar((12-1)*3 + j,( 8-1)*3 + l) + dPdF(i,j,k,l, 8)*n(i,12)*n(k, 8) &
+ dRdX(i,j,k,l,12)*n(i,12)*n(k, 8)
!
enddo
enddo
enddo
enddo
!
return
!
END SUBROUTINE
!
!
END MODULE
!##############################################################

55
patch/subroutine/FEsolving.f90 Normal file
View File

@ -0,0 +1,55 @@
!##############################################################
MODULE FEsolving
!##############################################################
use prec, only: pInt,pReal
implicit none
integer(pInt) cycleCounter
integer(pInt) theInc,theCycle,theLovl
real(pReal) theTime
logical :: lastIncConverged = .false.,outdatedByNewInc = .false.,outdatedFFN1 = .false.
logical :: symmetricSolver = .false.
logical :: parallelExecution = .true.
CONTAINS
!***********************************************************
! determine wether a symmetric solver is used
!***********************************************************
subroutine FE_init()
use prec, only: pInt
use IO
implicit none
integer(pInt), parameter :: fileunit = 222
integer(pInt), dimension (1+2*2) :: pos
character(len=1024) line
if (IO_open_inputFile(fileunit)) then
rewind(fileunit)
do
read (fileunit,'(a1024)',END=100) line
pos = IO_stringPos(line,1)
if( IO_lc(IO_stringValue(line,pos,1)) == 'solver' ) then
read (fileunit,'(a1024)',END=100) line ! Garbage line
pos = IO_stringPos(line,2)
symmetricSolver = (IO_intValue(line,pos,2) /= 1_pInt)
exit
endif
enddo
else
call IO_error(100) ! cannot open input file
endif
100 close(fileunit)
return
end subroutine
END MODULE FEsolving

904
patch/subroutine/IO.f90 Normal file
View File

@ -0,0 +1,904 @@
!##############################################################
MODULE IO
!##############################################################
CONTAINS
!---------------------------
! function IO_open_file(unit,relPath)
! function IO_open_inputFile(unit)
! function IO_hybridIA(Nast,ODFfileName)
! private function hybridIA_reps(dV_V,steps,C)
! function IO_stringPos(line,maxN)
! function IO_stringValue(line,positions,pos)
! function IO_floatValue(line,positions,pos)
! function IO_intValue(line,positions,pos)
! function IO_fixedStringValue(line,ends,pos)
! function IO_fixedFloatValue(line,ends,pos)
! function IO_fixedFloatNoEValue(line,ends,pos)
! function IO_fixedIntValue(line,ends,pos)
! function IO_continousIntValues(unit,maxN)
! function IO_lc(line)
! subroutine IO_lcInplace(line)
! subroutine IO_error(ID)
! subroutine IO_warning(ID)
!---------------------------
!********************************************************************
! open existing file to given unit
! path to file is relative to working directory
!********************************************************************
logical FUNCTION IO_open_file(unit,relPath)
use prec, only: pInt
implicit none
character(len=*), parameter :: pathSep = achar(47)//achar(92) ! /, \
character(len=*) relPath
integer(pInt) unit
character(256) path
inquire(6, name=path) ! determine outputfile
open(unit,status='old',err=100,file=path(1:scan(path,pathSep,back=.true.))//relPath)
IO_open_file = .true.
return
100 IO_open_file = .false.
return
END FUNCTION
!********************************************************************
! open FEM inputfile to given unit
!********************************************************************
logical FUNCTION IO_open_inputFile(unit)
use prec, only: pReal, pInt
implicit none
character(256) outName
integer(pInt) unit, extPos
character(3) ext
inquire(6, name=outName) ! determine outputfileName
extPos = len_trim(outName)-2
if(outName(extPos:extPos+2)=='out') then
ext='dat' ! MARC
else
ext='inp' ! ABAQUS
end if
open(unit,status='old',err=100,file=outName(1:extPos-1)//ext)
IO_open_inputFile = .true.
return
100 IO_open_inputFile = .false.
return
END FUNCTION
!********************************************************************
! hybrid IA repetition counter
!********************************************************************
FUNCTION hybridIA_reps(dV_V,steps,C)
use prec, only: pReal, pInt
implicit none
integer(pInt), intent(in), dimension(3) :: steps
integer(pInt) hybridIA_reps, phi1,Phi,phi2
real(pReal), intent(in), dimension(steps(3),steps(2),steps(1)) :: dV_V
real(pReal), intent(in) :: C
hybridIA_reps = 0_pInt
do phi1=1,steps(1)
do Phi =1,steps(2)
do phi2=1,steps(3)
hybridIA_reps = hybridIA_reps+nint(C*dV_V(phi2,Phi,phi1), pInt)
end do
end do
end do
return
END FUNCTION
!********************************************************************
! hybrid IA sampling of ODFfile
!********************************************************************
FUNCTION IO_hybridIA(Nast,ODFfileName)
use prec, only: pReal, pInt
use math, only: inRad
implicit none
character(len=*) ODFfileName
character(len=80) line
character(len=*), parameter :: fileFormat = '(A80)'
integer(pInt) i,j,bin,Nast,NnonZero,Nset,Nreps,reps,phi1,Phi,phi2
integer(pInt), dimension(7) :: pos
integer(pInt), dimension(3) :: steps
integer(pInt), dimension(:), allocatable :: binSet
real(pReal) center,sum_dV_V,prob,dg_0,C,lowerC,upperC,rnd
real(pReal), dimension(3) :: limits,deltas
real(pReal), dimension(:,:,:), allocatable :: dV_V
real(pReal), dimension(3,Nast) :: IO_hybridIA
if (.not. IO_open_file(999,ODFfileName)) goto 100
!--- parse header of ODF file ---
!--- limits in phi1, Phi, phi2 ---
read(999,fmt=fileFormat,end=100) line
pos = IO_stringPos(line,3)
if (pos(1).ne.3) goto 100
do i=1,3
limits(i) = IO_intValue(line,pos,i)*inRad
end do
!--- deltas in phi1, Phi, phi2 ---
read(999,fmt=fileFormat,end=100) line
pos = IO_stringPos(line,3)
if (pos(1).ne.3) goto 100
do i=1,3
deltas(i) = IO_intValue(line,pos,i)*inRad
end do
steps = nint(limits/deltas,pInt)
allocate(dV_V(steps(3),steps(2),steps(1)))
!--- box boundary/center at origin? ---
read(999,fmt=fileFormat,end=100) line
if (index(IO_lc(line),'bound')>0) then
center = 0.5_pReal
else
center = 0.0_pReal
end if
!--- skip blank line ---
read(999,fmt=fileFormat,end=100) line
sum_dV_V = 0.0_pReal
dV_V = 0.0_pReal
dg_0 = deltas(1)*deltas(3)*2.0_pReal*sin(deltas(2)/2.0_pReal)
NnonZero = 0_pInt
do phi1=1,steps(1)
do Phi=1,steps(2)
do phi2=1,steps(3)
read(999,fmt=*,end=100) prob
if (prob > 0.0_pReal) then
NnonZero = NnonZero+1
sum_dV_V = sum_dV_V+prob
else
prob = 0.0_pReal
end if
dV_V(phi2,Phi,phi1) = prob*dg_0*sin((Phi-1.0_pReal+center)*deltas(2))
end do
end do
end do
dV_V = dV_V/sum_dV_V ! normalize to 1
!--- now fix bounds ---
Nset = max(Nast,NnonZero)
lowerC = 0.0_pReal
upperC = real(Nset, pReal)
do while (hybridIA_reps(dV_V,steps,upperC) < Nset)
lowerC = upperC
upperC = upperC*2.0_pReal
end do
!--- binary search for best C ---
do
C = (upperC+lowerC)/2.0_pReal
Nreps = hybridIA_reps(dV_V,steps,C)
if (abs(upperC-lowerC) < upperC*1.0e-14_pReal) then
C = upperC
Nreps = hybridIA_reps(dV_V,steps,C)
exit
elseif (Nreps < Nset) then
lowerC = C
elseif (Nreps > Nset) then
upperC = C
else
exit
end if
end do
allocate(binSet(Nreps))
bin = 0 ! bin counter
i = 1 ! set counter
do phi1=1,steps(1)
do Phi=1,steps(2)
do phi2=1,steps(3)
reps = nint(C*dV_V(phi2,Phi,phi1), pInt)
binSet(i:i+reps-1) = bin
bin = bin+1 ! advance bin
i = i+reps ! advance set
end do
end do
end do
do i=1,Nast
if (i < Nast) then
call random_number(rnd)
j = nint(rnd*(Nast-i)+i+0.5_pReal,pInt)
else
j = i
end if
bin = binSet(j)
IO_hybridIA(1,i) = deltas(1)*(mod(bin/(steps(3)*steps(2)),steps(1))+center) ! phi1
IO_hybridIA(2,i) = deltas(2)*(mod(bin/ steps(3) ,steps(2))+center) ! Phi
IO_hybridIA(3,i) = deltas(3)*(mod(bin ,steps(3))+center) ! phi2
binSet(j) = binSet(i)
end do
close(999)
return
! on error
100 IO_hybridIA = -1
close(999)
return
END FUNCTION
!********************************************************************
! identifies lines without content
!********************************************************************
PURE FUNCTION IO_isBlank (line)
use prec, only: pInt
implicit none
character(len=*), intent(in) :: line
character(len=*), parameter :: blank = achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces
character(len=*), parameter :: comment = achar(35) ! comment id '#'
integer(pInt) posNonBlank, posComment
logical IO_isBlank
posNonBlank = verify(line,blank)
posComment = scan(line,comment)
IO_isBlank = posNonBlank == 0 .or. posNonBlank == posComment
return
END FUNCTION
!********************************************************************
! get tagged content of line
!********************************************************************
PURE FUNCTION IO_getTag (line,openChar,closechar)
use prec, only: pInt
implicit none
character(len=*), intent(in) :: line,openChar,closeChar
character(len=*), parameter :: sep=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces
character(len=len_trim(line)) IO_getTag
integer(pInt) left,right
IO_getTag = ''
left = scan(line,openChar)
right = scan(line,closeChar)
if (left == verify(line,sep) .and. right > left) & ! openChar is first and closeChar occurs
IO_getTag = line(left+1:right-1)
return
END FUNCTION
!*********************************************************************
FUNCTION IO_countSections(file,part)
!*********************************************************************
use prec, only: pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: file
character(len=*), intent(in) :: part
integer(pInt) IO_countSections
character(len=1024) line
IO_countSections = 0
line = ''
rewind(file)
do while (IO_getTag(line,'<','>') /= part) ! search for part
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') & ! found [section] identifier
IO_countSections = IO_countSections + 1
enddo
100 return
END FUNCTION
!*********************************************************************
! return array of myTag counts within <part> for at most N[sections]
!*********************************************************************
FUNCTION IO_countTagInPart(file,part,myTag,Nsections)
use prec, only: pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: file, Nsections
character(len=*), intent(in) :: part, myTag
integer(pInt), dimension(Nsections) :: IO_countTagInPart, counter
integer(pInt), parameter :: maxNchunks = 1
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) section
character(len=1024) line,tag
counter = 0_pInt
section = 0_pInt
line = ''
rewind(file)
do while (IO_getTag(line,'<','>') /= part) ! search for part
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') & ! found [section] identifier
section = section + 1
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
if (tag == myTag) & ! match
counter(section) = counter(section) + 1
endif
enddo
100 IO_countTagInPart = counter
return
END FUNCTION
!*********************************************************************
! return array of myTag presence within <part> for at most N[sections]
!*********************************************************************
FUNCTION IO_spotTagInPart(file,part,myTag,Nsections)
use prec, only: pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: file, Nsections
character(len=*), intent(in) :: part, myTag
logical, dimension(Nsections) :: IO_spotTagInPart
integer(pInt), parameter :: maxNchunks = 1
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) section
character(len=1024) line,tag
IO_spotTagInPart = .false. ! assume to nowhere spot tag
section = 0_pInt
line = ''
rewind(file)
do while (IO_getTag(line,'<','>') /= part) ! search for part
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') & ! found [section] identifier
section = section + 1
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
if (tag == myTag) & ! match
IO_spotTagInPart(section) = .true.
endif
enddo
100 return
END FUNCTION
!********************************************************************
! locate at most N space-separated parts in line
! return array containing number of parts found and
! their left/right positions to be used by IO_xxxVal
!********************************************************************
PURE FUNCTION IO_stringPos (line,N)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
character(len=*), parameter :: sep=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces
integer(pInt), intent(in) :: N
integer(pInt) part
integer(pInt) IO_stringPos(1+N*2)
IO_stringPos = -1
IO_stringPos(1) = 0
part = 1
do while ((N<1 .or. part<=N) .and. verify(line(IO_stringPos(part*2-1)+1:),sep)>0)
IO_stringPos(part*2) = IO_stringPos(part*2-1)+verify(line(IO_stringPos(part*2-1)+1:),sep)
IO_stringPos(part*2+1) = IO_stringPos(part*2)+scan(line(IO_stringPos(part*2):),sep)-2
part = part+1
end do
IO_stringPos(1) = part-1
return
END FUNCTION
!********************************************************************
! read string value at pos from line
!********************************************************************
PURE FUNCTION IO_stringValue (line,positions,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: positions(*),pos
character(len=1+positions(pos*2+1)-positions(pos*2)) IO_stringValue
if (positions(1) < pos) then
IO_stringValue = ''
else
IO_stringValue = line(positions(pos*2):positions(pos*2+1))
endif
return
END FUNCTION
!********************************************************************
! read string value at pos from fixed format line
!********************************************************************
PURE FUNCTION IO_fixedStringValue (line,ends,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: ends(*),pos
character(len=ends(pos+1)-ends(pos)) IO_fixedStringValue
IO_fixedStringValue = line(ends(pos)+1:ends(pos+1))
return
END FUNCTION
!********************************************************************
! read float value at pos from line
!********************************************************************
PURE FUNCTION IO_floatValue (line,positions,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: positions(*),pos
real(pReal) IO_floatValue
if (positions(1) >= pos) then
read(UNIT=line(positions(pos*2):positions(pos*2+1)),ERR=100,FMT=*) IO_floatValue
return
endif
100 IO_floatValue = huge(1.0_pReal)
return
END FUNCTION
!********************************************************************
! read float value at pos from fixed format line
!********************************************************************
PURE FUNCTION IO_fixedFloatValue (line,ends,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: ends(*),pos
real(pReal) IO_fixedFloatValue
read(UNIT=line(ends(pos-1)+1:ends(pos)),ERR=100,FMT=*) IO_fixedFloatValue
return
100 IO_fixedFloatValue = huge(1.0_pReal)
return
END FUNCTION
!********************************************************************
! read float x.y+z value at pos from format line line
!********************************************************************
PURE FUNCTION IO_fixedNoEFloatValue (line,ends,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: ends(*),pos
integer(pInt) pos_exp,expon
real(pReal) IO_fixedNoEFloatValue,base
pos_exp = scan(line(ends(pos)+1:ends(pos+1)),'+-',back=.true.)
if (pos_exp > 1) then
read(UNIT=line(ends(pos)+1:ends(pos)+pos_exp-1),ERR=100,FMT=*) base
read(UNIT=line(ends(pos)+pos_exp:ends(pos+1)),ERR=100,FMT=*) expon
else
read(UNIT=line(ends(pos)+1:ends(pos+1)),ERR=100,FMT=*) base
expon = 0_pInt
endif
IO_fixedNoEFloatValue = base*10.0_pReal**expon
return
100 IO_fixedNoEFloatValue = huge(1.0_pReal)
return
END FUNCTION
!********************************************************************
! read int value at pos from line
!********************************************************************
PURE FUNCTION IO_intValue (line,positions,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: positions(*),pos
integer(pInt) IO_intValue
if (positions(1) >= pos) then
read(UNIT=line(positions(pos*2):positions(pos*2+1)),ERR=100,FMT=*) IO_intValue
return
endif
100 IO_intValue = huge(1_pInt)
return
END FUNCTION
!********************************************************************
! read int value at pos from fixed format line
!********************************************************************
PURE FUNCTION IO_fixedIntValue (line,ends,pos)
use prec, only: pReal,pInt
implicit none
character(len=*), intent(in) :: line
integer(pInt), intent(in) :: ends(*),pos
integer(pInt) IO_fixedIntValue
read(UNIT=line(ends(pos)+1:ends(pos+1)),ERR=100,FMT=*) IO_fixedIntValue
return
100 IO_fixedIntValue = huge(1_pInt)
return
END FUNCTION
!********************************************************************
! change character in line to lower case
!********************************************************************
PURE FUNCTION IO_lc (line)
use prec, only: pInt
implicit none
character (len=*), intent(in) :: line
character (len=len(line)) IO_lc
integer(pInt) i
IO_lc = line
do i=1,len(line)
if(64<iachar(line(i:i)) .and. iachar(line(i:i))<91) IO_lc(i:i)=achar(iachar(line(i:i))+32)
enddo
return
END FUNCTION
!********************************************************************
! in place change of character in line to lower case
!********************************************************************
SUBROUTINE IO_lcInplace (line)
use prec, only: pInt
implicit none
character (len=*) line
character (len=len(line)) IO_lc
integer(pInt) i
IO_lc = line
do i=1,len(line)
if(64<iachar(line(i:i)) .and. iachar(line(i:i))<91) IO_lc(i:i)=achar(iachar(line(i:i))+32)
enddo
line = IO_lc
return
END SUBROUTINE
!********************************************************************
! read on in file to skip (at least) N chunks (may be over multiple lines)
!********************************************************************
SUBROUTINE IO_skipChunks (unit,N)
use prec, only: pReal,pInt
implicit none
integer(pInt) remainingChunks,unit,N
integer(pInt), parameter :: maxNchunks = 64
integer(pInt), dimension(1+2*maxNchunks) :: pos
character(len=300) line
remainingChunks = N
do while (remainingChunks > 0)
read(unit,'(A300)',end=100) line
pos = IO_stringPos(line,maxNchunks)
remainingChunks = remainingChunks - pos(1)
end do
100 return
END SUBROUTINE
!********************************************************************
! count items in consecutive lines of ints concatenated by "c"
! as last char or range of values a "to" b
!********************************************************************
FUNCTION IO_countContinousIntValues (unit)
use prec, only: pReal,pInt
implicit none
integer(pInt) IO_countContinousIntValues,unit
integer(pInt), dimension(67) :: pos ! allow for 32 values excl "c"
character(len=300) line
IO_countContinousIntValues = 0
do
read(unit,'(A300)',end=100) line
pos = IO_stringPos(line,33)
if (IO_lc(IO_stringValue(line,pos,2)) == 'to' ) then ! found range indicator
IO_countContinousIntValues = IO_countContinousIntValues+1+IO_intValue(line,pos,3)-IO_intValue(line,pos,1)
exit
else
IO_countContinousIntValues = IO_countContinousIntValues+pos(1)-1
if ( IO_lc(IO_stringValue(line,pos,pos(1))) /= 'c' ) then ! line finished, read last value
IO_countContinousIntValues = IO_countContinousIntValues+1
exit
endif
endif
enddo
100 return
END FUNCTION
!*********************************************************************
! read consecutive lines of ints concatenated by "c" as last char
! or range of values a "to" b
!*********************************************************************
FUNCTION IO_continousIntValues (unit,maxN,lookupName,lookupMap,lookupMaxN)
use prec, only: pReal,pInt
implicit none
integer(pInt) unit,maxN,i
integer(pInt), dimension(1+maxN) :: IO_continousIntValues
integer(pInt), dimension(67) :: pos ! allow for 32 values excl "c"
character(len=64), dimension(:) :: lookupName
integer(pInt) :: lookupMaxN
integer(pInt), dimension(:,:) :: lookupMap
character(len=300) line
IO_continousIntValues = 0_pInt
do
read(unit,'(A300)',end=100) line
pos = IO_stringPos(line,33)
if (verify(IO_stringValue(line,pos,1),"0123456789") > 0) then ! a non-int, i.e. set name
do i = 1,lookupMaxN ! loop over known set names
if (IO_stringValue(line,pos,1) == lookupName(i)) then ! found matching name
IO_continousIntValues = lookupMap(:,i) ! return resp. entity list
exit
endif
enddo
exit
else if (IO_lc(IO_stringValue(line,pos,2)) == 'to' ) then ! found range indicator
do i = IO_intValue(line,pos,1),IO_intValue(line,pos,3)
IO_continousIntValues(1) = IO_continousIntValues(1)+1
IO_continousIntValues(1+IO_continousIntValues(1)) = i
enddo
exit
else
do i = 1,pos(1)-1 ! interpret up to second to last value
IO_continousIntValues(1) = IO_continousIntValues(1)+1
IO_continousIntValues(1+IO_continousIntValues(1)) = IO_intValue(line,pos,i)
enddo
if ( IO_lc(IO_stringValue(line,pos,pos(1))) /= 'c' ) then ! line finished, read last value
IO_continousIntValues(1) = IO_continousIntValues(1)+1
IO_continousIntValues(1+IO_continousIntValues(1)) = IO_intValue(line,pos,pos(1))
exit
endif
endif
enddo
100 return
END FUNCTION
!********************************************************************
! write error statements to standard out
! and terminate the Marc run with exit #9xxx
! in ABAQUS either time step is reduced or execution terminated
!********************************************************************
SUBROUTINE IO_error(ID,e,i,g,ext_msg)
use prec, only: pInt
use debug
implicit none
integer(pInt), intent(in) :: ID
integer(pInt), optional, intent(in) :: e,i,g
character(len=*), optional, intent(in) :: ext_msg
character(len=80) msg
select case (ID)
case (0)
msg = 'Unable to open input file'
case (100)
msg = 'Error reading from configuration file'
case (105)
msg = 'Error reading from ODF file'
case (110)
msg = 'No homogenization specified via State Variable 2'
case (120)
msg = 'No microstructure specified via State Variable 3'
case (130)
msg = 'Homogenization index out of bounds'
case (140)
msg = 'Microstructure index out of bounds'
case (150)
msg = 'Phase index out of bounds'
case (160)
msg = 'Texture index out of bounds'
case (170)
msg = 'Sum of phase fractions differs from 1'
case (200)
msg = 'Unknown constitution specified'
case (201)
msg = 'Unknown lattice type specified'
case (202)
msg = 'Number of slip systems too small'
case (203)
msg = 'Negative initial slip resistance'
case (204)
msg = 'Non-positive reference shear rate'
case (205)
msg = 'Non-positive stress exponent'
case (206)
msg = 'Non-positive initial hardening slope'
case (207)
msg = 'Non-positive saturation stress'
case (208)
msg = 'Non-positive w0'
case (209)
msg = 'Negative latent hardening ratio'
case (220)
msg = 'Negative initial dislocation density'
case (221)
msg = 'Negative Bugers vector'
case (222)
msg = 'Negative activation energy for edge dislocation glide'
case (223)
msg = 'Negative self diffusion energy'
case (224)
msg = 'Negative diffusion constant'
case (240)
msg = 'Non-positive Taylor factor'
case (300)
msg = 'This material can only be used with elements with three direct stress components'
case (500)
msg = 'Unknown lattice type specified'
case (600)
msg = 'Convergence not reached'
case (610)
msg = 'Stress loop not converged'
case (700)
msg = 'Singular matrix in stress iteration'
case (800)
msg = 'GIA requires 8 grains per IP (bonehead, you!)'
case default
msg = 'Unknown error number...'
end select
!$OMP CRITICAL (write2out)
write(6,*)
write(6,*) '+------------------------------+'
write(6,*) '+ ERROR +'
write(6,*) '+ +'
write(6,*) msg
if (present(ext_msg)) write(6,*) ext_msg
if (present(e)) then
if (present(i) .and. present(g)) then
write(6,'(a10,x,i6,x,a2,x,i2,x,a5,x,i4)') 'at element',e,'IP',i,'grain',g
else
write(6,'(a2,x,i6)') 'at',e
endif
endif
write(6,*) '+------------------------------+'
call debug_info()
call flush(6)
call quit(9000+ID)
!$OMP END CRITICAL (write2out)
! ABAQUS returns in some cases
return
END SUBROUTINE
!********************************************************************
! write warning statements to standard out
!********************************************************************
SUBROUTINE IO_warning(ID,e,i,g,ext_msg)
use prec, only: pInt
use debug
implicit none
integer(pInt), intent(in) :: ID
integer(pInt), optional, intent(in) :: e,i,g
character(len=*), optional, intent(in) :: ext_msg
character(len=80) msg
select case (ID)
case (650)
msg = 'Polar decomposition failed'
case default
msg = 'Unknown warning number...'
end select
!$OMP CRITICAL (write2out)
write(6,*)
write(6,*) '+------------------------------+'
write(6,*) '+ warning +'
write(6,*) '+ +'
write(6,*) msg
if (present(ext_msg)) write(6,*) ext_msg
if (present(e)) then
if (present(i) .and. present(g)) then
write(6,'(a10,x,i6,x,a2,x,i2,x,a5,x,i4)') 'at element',e,'IP',i,'grain',g
else
write(6,'(a2,x,i6)') 'at',e
endif
endif
write(6,*) '+------------------------------+'
END SUBROUTINE
END MODULE IO

182
patch/subroutine/concom2007r1 Normal file
View File

@ -0,0 +1,182 @@
! reformated to free format
!***********************************************************************
!
! File: concom.cmn
!
! MSC.Marc include file
!
integer(pInt) &
iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,&
ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,&
ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,&
ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,&
itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,&
lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,&
icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,&
isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,&
ibukty, iassum, icnstd, icnstt, kmakmas, imethvp,iradrte,iradrtp, iupdate,iupdatp,&
ncycnt, marmen ,idynme, ihavca, ispf, kmini, imixed, largtt, kdoela, iautofg,&
ipshftp,idntrc, ipore, jtablm, jtablc, isnecma,itrnspo,imsdif, jtrnspo,mcnear,&
imech, imecht, ielcmat, ielectt,magnett, imsdift,noplas, jtabls, jactch, jtablth,&
kgmsto ,jpzo, ifricsh, iremkin,iremfor, ishearp,jspf, machining, jlshell,icompsol,&
iupblgfo,jcondir,nstcrp, nactive,ipassref, nstspnt,ibeart,icheckmpc, noline, icuring,&
ishrink,ioffsflg,isetoff, ioffsetm,iharmt, inc_incdat,iautspc,ibrake, icbush ,istream_input,&
iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1
common/marc_concom/&
iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva(50), idyn, idynt,&
ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,&
ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,&
ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,&
itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,&
lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,&
icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,&
isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,&
ibukty, iassum, icnstd, icnstt, kmakmas, imethvp,iradrte,iradrtp, iupdate,iupdatp,&
ncycnt, marmen ,idynme, ihavca, ispf, kmini, imixed, largtt, kdoela, iautofg,&
ipshftp,idntrc, ipore, jtablm, jtablc, isnecma,itrnspo,imsdif, jtrnspo,mcnear,&
imech, imecht, ielcmat, ielectt,magnett, imsdift,noplas, jtabls, jactch, jtablth,&
kgmsto ,jpzo, ifricsh, iremkin,iremfor, ishearp,jspf, machining, jlshell,icompsol,&
iupblgfo,jcondir,nstcrp, nactive,ipassref, nstspnt,ibeart,icheckmpc, noline, icuring,&
ishrink,ioffsflg,isetoff, ioffsetm,iharmt, inc_incdat,iautspc,ibrake, icbush ,istream_input,&
iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1
!
! comments of variables:
!
! ideva(50) - debug print out flag
! 1 print element stiffness matrices, mass matrix
! 2 output matrices used in tying
! 3 force the solution of a nonpositive definite matrix
! 4 print info of connections to each node
! 5 info of gap convergence, internal heat generated, contact
! touching and separation
! 6 nodal value array during rezoning
! 7 tying info in CONRAD GAP option, fluid element numbers in
! CHANNEL option
! 8 output incremental displacements in local coord. system
! 9 latent heat output
! 10 stress-strain in local coord. system
! 11 additional info on interlaminar stress
! 12 output right hand side and solution vector
! 13 info of CPU resources used and memory available on NT
! 14 info of mesh adaption process, 2D outline information
! info of penetration checking for remeshing
! save .fem files after afmesh3d meshing
! 15 surface energy balance flag
! 16 print info regarding pyrolysis
! 17 print info of "streamline topology"
! 18 print mesh data changes after remeshing
! 19 print material flow stress data read in from *.mat file
! if unit flag is on, print out flow stress after conversion
! 20 print information on table input
! 21 print out information regarding kinematic boundary conditions
! 22 print out information regarding dist loads, point loads, film
! and foundations
! 23 print out information about automatic domain decomposition
! 24 print out iteration information in SuperForm status report file
! 25 print out information for ablation
! 26 print out information for films - Table input
! 27 print out the tying forces
! 28 print out for CASI solver, convection,
! 29 DDM single file debug printout
! 30 print out cavity debug info
! 31 print out welding related info
! 32 prints categorized DDM memory usage
! 33 print out the cutting info regarding machining feature
! 34 print out the list of quantities which can be defined via a table
! and for each quantity the supported independent variables
! 35 print out detailed coupling region info
! 36 print out solver debug info level 1 (Least Detailed)
! 37 print out solver debug info level 1 (Medium Detailed)
! 38 print out solver debug info level 1 (Very Detailed)
! 39 print detailed memory allocation info
! 40 print out marc-adams debug info
! 41 output rezone mapping post file for debugging
! 42 output post file after calling oprofos() for debugging
! 43 debug printout for vcct
! 44 debug printout for progressive failure
! 45 print out automatically generated midside node coordinates (arecrd)
! 46 print out message about routine and location, where the ibort is raised (ibort_inc)
! 47 print out summary message of element variables on a
! group-basis after all the automatic changes have been
! made (em_ellibp)
! 48 Automatically generate check results based on max and min vals.
! These vals are stored in the checkr file, which is inserted
! into the *dat file by the generate_check_results script from /marc/tools
! 49 Automatically generate check results based on the real calculated values
! at the sppecified check result locations.
! These vals are stored in the checkr file, which is inserted
! into the *dat file by the update_check_results script from /marc/tools
!
!
! jactch = 1 or 2 if elements are activated or deactivated
! = 3 if elements are adaptively remeshed or rezoned
! = 0 normally / reset to 0 when assembly is done
! ifricsh = 0 call to fricsh in otest not needed
! = 1 call to fricsh (nodal friction) in otest needed
! iremkin = 0 remove deactivated kinematic boundary conditions
! immediately - only in new input format (this is default)
! = 1 remove deactivated kinematic boundary conditions
! gradually - only in new input format
! iremfor = 0 remove force boundary conditions immediately -
! only in new input format (this is default)
! = 1 remove force boundary conditions gradually -
! only in new input format (this is default)
! ishearp set to 1 if shear panel elements are present in the model
!
! jspf = 0 not in spf loadcase
! > 0 in spf loadcase (jspf=1 during first increment)
! machining = 1 if the metal cutting feature is used, for memory allocation purpose
! = 0 (default) if no metal cutting feature required
!
! jlshell = 1 if there is a shell element in the mesh
! icompsol = 1 if there is a composite solid element in the mesh
! iupblgfo = 1 if follower force for point loads
! jcondir = 1 if contact priority option is used
! nstcrp = 0 (default) steady state creep flag (undocumented feature.
! if not 0, turns off special ncycle = 0 code in radial.f)
! nactive = number of active passes, if =1 then it's not a coupled analysis
! ipassref = reference ipass, if not in a multiphysics pass ipass=ipassref
! icheckmpc = value of mpc-check parameter option
! noline = set to 1 in osolty if no line seacrh should be done in ogetst
! icuring = set to 1 if the curing is included for the heat transfer analysis.
! ishrink = set to 1 if shrinkage strain is included for mechancial analysis.
! ioffsflg = 1 for small displacement beam/shell offsets
! = 2 for large displacement beam/shell offsets
! isetoff = 0 - do not apply beam/shell offsets
! = 1 - apply beam/shell offsets
! ioffsetm = min. value of offset flag
! inc_incdat = flag to record increment number of a new loadcase in incdat.f
! iautspc = flag for AutoSPC option
! ibrake = brake squeal in this increment
! icbush = set to 1 if cbush elements present in model
! istream_input = set to 1 for streaming input calling Marc as library
! iprsinp = set to 1 if pressure input, introduced so other variables
! such as h could be a function of pressure
! ivlsinp = set to 1 if velocity input, introduced so other variables
! such as h could be a function of velocity
! ipin_m = # of beam element with PIN flag
! jgnstr_glb = global control over pre or fast integrated composite shells
! imarc_return = Marc return flag for streaming input control
! iqvcimp = if non-zero, then the number of QVECT boundary conditions
! nqvceid = number of QVECT boundary conditions, where emisivity/absorbtion id entered
! istpnx = 1 if to stop at end of increment
! imicro1 = 1 if micro1 interface is used
! iaxisymm = set to 1 if axisymmetric analysis
! jbreakglue = set to 1 if breaking glued option is used
! iglstif = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9)
! jfastasm = 1 do fast assembly using SuperForm code
! iwear = set to 1 if wear model, set to 2 if wear model and coordinates updated
! iwearcf = set to 1 to store nodal coefficient of friction for wear calculation
! imixmeth = set=1 then use nonlinear mixture material - allocate memory
! ielcmadyn = flag for magnetodynamics
! 0 - electromagnetics using newmark beta
! 1 - transient magnetics using backward euler
! idinout = flag to control if inside out elements should be deactivated
! igena_meth = 0 - generalized alpha parameters depend on whether or not contact
! is flagged (dynamic,7)
! 10 - generalized alpha parameters are optimized for a contact
! analysis (dynamic,8)
! 11 - generalized alpha parameters are optimized for an analysis
! without contact (dynamic,8)
!
!***********************************************************************

186
patch/subroutine/concom2008r1 Normal file
View File

@ -0,0 +1,186 @@
! reformated to free format
!***********************************************************************
!
! File: concom.cmn
!
! MSC.Marc include file
!
integer(pInt) &
iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,&
ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,&
ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,&
ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,&
itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,&
lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,&
icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,&
isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,&
ibukty, iassum, icnstd, icnstt, kmakmas, imethvp,iradrte,iradrtp, iupdate,iupdatp,&
ncycnt, marmen ,idynme, ihavca, ispf, kmini, imixed, largtt, kdoela, iautofg,&
ipshftp,idntrc, ipore, jtablm, jtablc, isnecma,itrnspo,imsdif, jtrnspo,mcnear,&
imech, imecht, ielcmat, ielectt,magnett, imsdift,noplas, jtabls, jactch, jtablth,&
kgmsto ,jpzo, ifricsh, iremkin,iremfor, ishearp,jspf, machining, jlshell,icompsol,&
iupblgfo,jcondir,nstcrp, nactive,ipassref, nstspnt,ibeart,icheckmpc, noline, icuring,&
ishrink,ioffsflg,isetoff, ioffsetm,iharmt, inc_incdat,iautspc,ibrake, icbush ,istream_input,&
iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
iaxisymm,jbreakglue,iglstif,jfastasm,iwear, iwearcf, imixmeth,ielcmadyn,idinout,igena_meth
integer(pInt) num_concom
parameter(num_concom=219)
common/marc_concom/&
iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva(50), idyn, idynt,&
ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,&
ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,&
ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,&
itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,&
lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,&
icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,&
isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,&
ibukty, iassum, icnstd, icnstt, kmakmas, imethvp,iradrte,iradrtp, iupdate,iupdatp,&
ncycnt, marmen ,idynme, ihavca, ispf, kmini, imixed, largtt, kdoela, iautofg,&
ipshftp,idntrc, ipore, jtablm, jtablc, isnecma,itrnspo,imsdif, jtrnspo,mcnear,&
imech, imecht, ielcmat, ielectt,magnett, imsdift,noplas, jtabls, jactch, jtablth,&
kgmsto ,jpzo, ifricsh, iremkin,iremfor, ishearp,jspf, machining, jlshell,icompsol,&
iupblgfo,jcondir,nstcrp, nactive,ipassref, nstspnt,ibeart,icheckmpc, noline, icuring,&
ishrink,ioffsflg,isetoff, ioffsetm,iharmt, inc_incdat,iautspc,ibrake, icbush ,istream_input,&
iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
iaxisymm,jbreakglue,iglstif,jfastasm,iwear, iwearcf, imixmeth, ielcmadyn,idinout,igena_meth
!
! comments of variables:
!
! ideva(50) - debug print out flag
! 1 print element stiffness matrices, mass matrix
! 2 output matrices used in tying
! 3 force the solution of a nonpositive definite matrix
! 4 print info of connections to each node
! 5 info of gap convergence, internal heat generated, contact
! touching and separation
! 6 nodal value array during rezoning
! 7 tying info in CONRAD GAP option, fluid element numbers in
! CHANNEL option
! 8 output incremental displacements in local coord. system
! 9 latent heat output
! 10 stress-strain in local coord. system
! 11 additional info on interlaminar stress
! 12 output right hand side and solution vector
! 13 info of CPU resources used and memory available on NT
! 14 info of mesh adaption process, 2D outline information
! info of penetration checking for remeshing
! save .fem files after afmesh3d meshing
! 15 surface energy balance flag
! 16 print info regarding pyrolysis
! 17 print info of "streamline topology"
! 18 print mesh data changes after remeshing
! 19 print material flow stress data read in from *.mat file
! if unit flag is on, print out flow stress after conversion
! 20 print information on table input
! 21 print out information regarding kinematic boundary conditions
! 22 print out information regarding dist loads, point loads, film
! and foundations
! 23 print out information about automatic domain decomposition
! 24 print out iteration information in SuperForm status report file
! 25 print out information for ablation
! 26 print out information for films - Table input
! 27 print out the tying forces
! 28 print out for CASI solver, convection,
! 29 DDM single file debug printout
! 30 print out cavity debug info
! 31 print out welding related info
! 32 prints categorized DDM memory usage
! 33 print out the cutting info regarding machining feature
! 34 print out the list of quantities which can be defined via a table
! and for each quantity the supported independent variables
! 35 print out detailed coupling region info
! 36 print out solver debug info level 1 (Least Detailed)
! 37 print out solver debug info level 1 (Medium Detailed)
! 38 print out solver debug info level 1 (Very Detailed)
! 39 print detailed memory allocation info
! 40 print out marc-adams debug info
! 41 output rezone mapping post file for debugging
! 42 output post file after calling oprofos() for debugging
! 43 debug printout for vcct
! 44 debug printout for progressive failure
! 45 print out automatically generated midside node coordinates (arecrd)
! 46 print out message about routine and location, where the ibort is raised (ibort_inc)
! 47 print out summary message of element variables on a
! group-basis after all the automatic changes have been
! made (em_ellibp)
! 48 Automatically generate check results based on max and min vals.
! These vals are stored in the checkr file, which is inserted
! into the *dat file by the generate_check_results script from /marc/tools
! 49 Automatically generate check results based on the real calculated values
! at the sppecified check result locations.
! These vals are stored in the checkr file, which is inserted
! into the *dat file by the update_check_results script from /marc/tools
!
!
! jactch = 1 or 2 if elements are activated or deactivated
! = 3 if elements are adaptively remeshed or rezoned
! = 0 normally / reset to 0 when assembly is done
! ifricsh = 0 call to fricsh in otest not needed
! = 1 call to fricsh (nodal friction) in otest needed
! iremkin = 0 remove deactivated kinematic boundary conditions
! immediately - only in new input format (this is default)
! = 1 remove deactivated kinematic boundary conditions
! gradually - only in new input format
! iremfor = 0 remove force boundary conditions immediately -
! only in new input format (this is default)
! = 1 remove force boundary conditions gradually -
! only in new input format (this is default)
! ishearp set to 1 if shear panel elements are present in the model
!
! jspf = 0 not in spf loadcase
! > 0 in spf loadcase (jspf=1 during first increment)
! machining = 1 if the metal cutting feature is used, for memory allocation purpose
! = 0 (default) if no metal cutting feature required
!
! jlshell = 1 if there is a shell element in the mesh
! icompsol = 1 if there is a composite solid element in the mesh
! iupblgfo = 1 if follower force for point loads
! jcondir = 1 if contact priority option is used
! nstcrp = 0 (default) steady state creep flag (undocumented feature.
! if not 0, turns off special ncycle = 0 code in radial.f)
! nactive = number of active passes, if =1 then it's not a coupled analysis
! ipassref = reference ipass, if not in a multiphysics pass ipass=ipassref
! icheckmpc = value of mpc-check parameter option
! noline = set to 1 in osolty if no line seacrh should be done in ogetst
! icuring = set to 1 if the curing is included for the heat transfer analysis.
! ishrink = set to 1 if shrinkage strain is included for mechancial analysis.
! ioffsflg = 1 for small displacement beam/shell offsets
! = 2 for large displacement beam/shell offsets
! isetoff = 0 - do not apply beam/shell offsets
! = 1 - apply beam/shell offsets
! ioffsetm = min. value of offset flag
! inc_incdat = flag to record increment number of a new loadcase in incdat.f
! iautspc = flag for AutoSPC option
! ibrake = brake squeal in this increment
! icbush = set to 1 if cbush elements present in model
! istream_input = set to 1 for streaming input calling Marc as library
! iprsinp = set to 1 if pressure input, introduced so other variables
! such as h could be a function of pressure
! ivlsinp = set to 1 if velocity input, introduced so other variables
! such as h could be a function of velocity
! ipin_m = # of beam element with PIN flag
! jgnstr_glb = global control over pre or fast integrated composite shells
! imarc_return = Marc return flag for streaming input control
! iqvcimp = if non-zero, then the number of QVECT boundary conditions
! nqvceid = number of QVECT boundary conditions, where emisivity/absorbtion id entered
! istpnx = 1 if to stop at end of increment
! imicro1 = 1 if micro1 interface is used
! iaxisymm = set to 1 if axisymmetric analysis
! jbreakglue = set to 1 if breaking glued option is used
! iglstif = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9)
! jfastasm = 1 do fast assembly using SuperForm code
! iwear = set to 1 if wear model, set to 2 if wear model and coordinates updated
! iwearcf = set to 1 to store nodal coefficient of friction for wear calculation
! imixmeth = set=1 then use nonlinear mixture material - allocate memory
! ielcmadyn = flag for magnetodynamics
! 0 - electromagnetics using newmark beta
! 1 - transient magnetics using backward euler
! idinout = flag to control if inside out elements should be deactivated
! igena_meth = 0 - generalized alpha parameters depend on whether or not contact
! is flagged (dynamic,7)
! 10 - generalized alpha parameters are optimized for a contact
! analysis (dynamic,8)
! 11 - generalized alpha parameters are optimized for an analysis
! without contact (dynamic,8)
!
!***********************************************************************

293
patch/subroutine/constitutive.f90 Normal file
View File

@ -0,0 +1,293 @@
!************************************
!* Module: CONSTITUTIVE *
!************************************
!* contains: *
!* - constitutive equations *
!* - parameters definition *
!************************************
MODULE constitutive
!*** Include other modules ***
use prec
implicit none
type(p_vec), dimension(:,:,:), allocatable :: constitutive_state_old, & ! pointer array to old state variables of each grain
constitutive_state_new ! pointer array to new state variables of each grain
integer(pInt), dimension(:,:,:), allocatable :: constitutive_sizeDotState, & ! size of dotState array
constitutive_sizeState, & ! size of state array per grain
constitutive_sizePostResults ! size of postResults array per grain
integer(pInt) constitutive_maxSizeDotState,constitutive_maxSizeState,constitutive_maxSizePostResults
CONTAINS
!****************************************
!* - constitutive_init
!* - constitutive_homogenizedC
!* - constitutive_microstructure
!* - constitutive_LpAndItsTangent
!* - constitutive_dotState
!* - constitutive_postResults
!****************************************
subroutine constitutive_init()
!**************************************
!* Module initialization *
!**************************************
use prec, only: pReal,pInt
use IO, only: IO_error, IO_open_file
use mesh, only: mesh_maxNips,mesh_NcpElems,mesh_element,FE_Nips
use material
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
integer(pInt), parameter :: fileunit = 200
integer(pInt) e,i,g,myInstance
if(.not. IO_open_file(fileunit,material_configFile)) call IO_error (100) ! corrupt config file
call constitutive_phenomenological_init(fileunit) ! parse all phases of this constitution
call constitutive_j2_init(fileunit)
call constitutive_dislobased_init(fileunit)
close(fileunit)
allocate(constitutive_state_old(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems))
allocate(constitutive_state_new(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems))
allocate(constitutive_sizeDotState(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; constitutive_sizeDotState = 0_pInt
allocate(constitutive_sizeState(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; constitutive_sizeState = 0_pInt
allocate(constitutive_sizePostResults(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; constitutive_sizePostResults = 0_pInt
do e = 1,mesh_NcpElems ! loop over elements
do i = 1,FE_Nips(mesh_element(2,e)) ! loop over IPs
do g = 1,homogenization_Ngrains(mesh_element(3,e)) ! loop over grains
myInstance = phase_constitutionInstance(material_phase(g,i,e))
select case(phase_constitution(material_phase(g,i,e)))
case (constitutive_phenomenological_label)
allocate(constitutive_state_old(g,i,e)%p(constitutive_phenomenological_sizeState(myInstance)))
allocate(constitutive_state_new(g,i,e)%p(constitutive_phenomenological_sizeState(myInstance)))
constitutive_state_new(g,i,e)%p = constitutive_phenomenological_stateInit(myInstance)
constitutive_state_old(g,i,e)%p = constitutive_phenomenological_stateInit(myInstance)
constitutive_sizeDotState(g,i,e) = constitutive_phenomenological_sizeDotState(myInstance)
constitutive_sizeState(g,i,e) = constitutive_phenomenological_sizeState(myInstance)
constitutive_sizePostResults(g,i,e) = constitutive_phenomenological_sizePostResults(myInstance)
case (constitutive_j2_label)
allocate(constitutive_state_old(g,i,e)%p(constitutive_j2_sizeState(myInstance)))
allocate(constitutive_state_new(g,i,e)%p(constitutive_j2_sizeState(myInstance)))
constitutive_state_new(g,i,e)%p = constitutive_j2_stateInit(myInstance)
constitutive_state_old(g,i,e)%p = constitutive_j2_stateInit(myInstance)
constitutive_sizeDotState(g,i,e) = constitutive_j2_sizeDotState(myInstance)
constitutive_sizeState(g,i,e) = constitutive_j2_sizeState(myInstance)
constitutive_sizePostResults(g,i,e) = constitutive_j2_sizePostResults(myInstance)
case (constitutive_dislobased_label)
allocate(constitutive_state_old(g,i,e)%p(constitutive_dislobased_sizeState(myInstance)))
allocate(constitutive_state_new(g,i,e)%p(constitutive_dislobased_sizeState(myInstance)))
constitutive_state_new(g,i,e)%p = constitutive_dislobased_stateInit(myInstance)
constitutive_state_old(g,i,e)%p = constitutive_dislobased_stateInit(myInstance)
constitutive_sizeDotState(g,i,e) = constitutive_dislobased_sizeDotState(myInstance)
constitutive_sizeState(g,i,e) = constitutive_dislobased_sizeState(myInstance)
constitutive_sizePostResults(g,i,e) = constitutive_dislobased_sizePostResults(myInstance)
case default
call IO_error(200,material_phase(g,i,e)) ! unknown constitution
end select
enddo
enddo
enddo
constitutive_maxSizeDotState = maxval(constitutive_sizeDotState)
constitutive_maxSizeState = maxval(constitutive_sizeState)
constitutive_maxSizePostResults = maxval(constitutive_sizePostResults)
return
end subroutine
function constitutive_homogenizedC(ipc,ip,el)
!*********************************************************************
!* This function returns the homogenized elacticity matrix *
!* INPUT: *
!* - state : state variables *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt
use material, only: phase_constitution,material_phase
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
real(pReal), dimension(6,6) :: constitutive_homogenizedC
select case (phase_constitution(material_phase(ipc,ip,el)))
case (constitutive_phenomenological_label)
constitutive_homogenizedC = constitutive_phenomenological_homogenizedC(constitutive_state_new,ipc,ip,el)
case (constitutive_j2_label)
constitutive_homogenizedC = constitutive_j2_homogenizedC(constitutive_state_new,ipc,ip,el)
case (constitutive_dislobased_label)
constitutive_homogenizedC = constitutive_dislobased_homogenizedC(constitutive_state_new,ipc,ip,el)
end select
return
end function
subroutine constitutive_microstructure(Temperature,ipc,ip,el)
!*********************************************************************
!* This function calculates from state needed variables *
!* INPUT: *
!* - state : state variables *
!* - Tp : temperature *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt
use material, only: phase_constitution,material_phase
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
real(pReal) Temperature
select case (phase_constitution(material_phase(ipc,ip,el)))
case (constitutive_phenomenological_label)
call constitutive_phenomenological_microstructure(Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_j2_label)
call constitutive_j2_microstructure(Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_dislobased_label)
call constitutive_dislobased_microstructure(Temperature,constitutive_state_new,ipc,ip,el)
end select
end subroutine
subroutine constitutive_LpAndItsTangent(Lp,dLp_dTstar, Tstar_v,Temperature,ipc,ip,el)
!*********************************************************************
!* This subroutine contains the constitutive equation for *
!* calculating the velocity gradient *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - Lp : plastic velocity gradient *
!* - dLp_dTstar : derivative of Lp (4th-order tensor) *
!*********************************************************************
use prec, only: pReal,pInt
use material, only: phase_constitution,material_phase
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
real(pReal) Temperature
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(3,3) :: Lp
real(pReal), dimension(9,9) :: dLp_dTstar
select case (phase_constitution(material_phase(ipc,ip,el)))
case (constitutive_phenomenological_label)
call constitutive_phenomenological_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_j2_label)
call constitutive_j2_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_dislobased_label)
call constitutive_dislobased_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
end select
return
end subroutine
function constitutive_dotState(Tstar_v,Temperature,ipc,ip,el)
!*********************************************************************
!* This subroutine contains the constitutive equation for *
!* calculating the rate of change of microstructure *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - state : current microstructure *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - constitutive_dotState : evolution of state variable *
!*********************************************************************
use prec, only: pReal,pInt
use material, only: phase_constitution,material_phase
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
real(pReal) Temperature
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(constitutive_sizeDotState(ipc,ip,el)) :: constitutive_dotState
select case (phase_constitution(material_phase(ipc,ip,el)))
case (constitutive_phenomenological_label)
constitutive_dotState = constitutive_phenomenological_dotState(Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_j2_label)
constitutive_dotState = constitutive_j2_dotState(Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
case (constitutive_dislobased_label)
constitutive_dotState = constitutive_dislobased_dotState(Tstar_v,Temperature,constitutive_state_new,ipc,ip,el)
end select
return
end function
pure function constitutive_postResults(Tstar_v,Temperature,dt,ipc,ip,el)
!*********************************************************************
!* return array of constitutive results *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - dt : current time increment *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt
use material, only: phase_constitution,material_phase
use constitutive_phenomenological
use constitutive_j2
use constitutive_dislobased
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
real(pReal), intent(in) :: dt,Temperature
real(pReal), dimension(6), intent(in) :: Tstar_v
real(pReal), dimension(constitutive_sizePostResults(ipc,ip,el)) :: constitutive_postResults
constitutive_postResults = 0.0_pReal
select case (phase_constitution(material_phase(ipc,ip,el)))
case (constitutive_phenomenological_label)
constitutive_postResults = constitutive_phenomenological_postResults(Tstar_v,Temperature,dt,constitutive_state_new,ipc,ip,el)
case (constitutive_j2_label)
constitutive_postResults = constitutive_j2_postResults(Tstar_v,Temperature,dt,constitutive_state_new,ipc,ip,el)
case (constitutive_dislobased_label)
constitutive_postResults = constitutive_dislobased_postResults(Tstar_v,Temperature,dt,constitutive_state_new,ipc,ip,el)
end select
return
end function
END MODULE

591
patch/subroutine/constitutive_dislobased.f90 Normal file
View File

@ -0,0 +1,591 @@
!************************************
!* Module: CONSTITUTIVE *
!************************************
!* contains: *
!* - constitutive equations *
!* - parameters definition *
!* - orientations *
!************************************
! [Alu]
! constitution dislobased
! (output) dislodensity
! (output) rateofshear
! lattice_structure 1
! Nslip 12
!
! c11 106.75e9
! c12 60.41e9
! c44 28.34e9
!
! burgers 2.86e-10 # Burgers vector [m]
! Qedge 3e-19 # Activation energy for dislocation glide [J/K] (0.5*G*b^3)
! Qsd 2.4e-19 # Activation energy for self diffusion [J/K] (gamma-iron)
! diff0 1e-3 # prefactor vacancy diffusion coeffficent (gamma-iron)
! interaction_coefficients 1.0 2.2 3.0 1.6 3.8 4.5 # Dislocation interaction coefficients
!
! rho0 6.0e12 # Initial dislocation density [m/m^3]
!
! c1 0.1 # Passing stress adjustment
! c2 2.0 # Jump width adjustment
! c3 1.0 # Activation volume adjustment
! c4 50.0 # Average slip distance adjustment for lock formation
! c7 8.0 # Athermal recovery adjustment
! c8 1.0e10 # Thermal recovery adjustment (plays no role for me)
MODULE constitutive_dislobased
!*** Include other modules ***
use prec, only: pReal,pInt
implicit none
character (len=*), parameter :: constitutive_dislobased_label = 'dislobased'
integer(pInt), dimension(:), allocatable :: constitutive_dislobased_sizeDotState, &
constitutive_dislobased_sizeState, &
constitutive_dislobased_sizePostResults
character(len=64), dimension(:,:), allocatable :: constitutive_dislobased_output
character(len=32), dimension(:), allocatable :: constitutive_dislobased_structureName
integer(pInt), dimension(:), allocatable :: constitutive_dislobased_structure
integer(pInt), dimension(:), allocatable :: constitutive_dislobased_Nslip
real(pReal), dimension(:), allocatable :: constitutive_dislobased_C11
real(pReal), dimension(:), allocatable :: constitutive_dislobased_C12
real(pReal), dimension(:), allocatable :: constitutive_dislobased_C13
real(pReal), dimension(:), allocatable :: constitutive_dislobased_C33
real(pReal), dimension(:), allocatable :: constitutive_dislobased_C44
real(pReal), dimension(:), allocatable :: constitutive_dislobased_Gmod
real(pReal), dimension(:,:,:), allocatable :: constitutive_dislobased_Cslip_66
!* Visco-plastic constitutive_phenomenological parameters
real(pReal), dimension(:), allocatable :: constitutive_dislobased_rho0
real(pReal), dimension(:), allocatable :: constitutive_dislobased_bg
real(pReal), dimension(:), allocatable :: constitutive_dislobased_Qedge
real(pReal), dimension(:), allocatable :: constitutive_dislobased_Qsd
real(pReal), dimension(:), allocatable :: constitutive_dislobased_D0
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c1
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c2
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c3
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c4
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c5
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c6
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c7
real(pReal), dimension(:), allocatable :: constitutive_dislobased_c8
real(pReal), dimension(:), allocatable :: constitutive_dislobased_CoverA
real(pReal), dimension(:,:), allocatable :: constitutive_dislobased_SlipIntCoeff
real(pReal), dimension(:,:,:), allocatable :: constitutive_dislobased_Iparallel
real(pReal), dimension(:,:,:), allocatable :: constitutive_dislobased_Iforest
!*************************************
!* Definition of material properties *
!*************************************
!* Physical parameter, attack_frequency != Debye frequency
real(pReal), parameter :: attack_frequency = 1.0e10_pReal
!* Physical parameter, Boltzmann constant in J/Kelvin
real(pReal), parameter :: kB = 1.38e-23_pReal
!* Physical parameter, Avogadro number in 1/mol
real(pReal), parameter :: avogadro = 6.022e23_pReal
!* Physical parameter, Gas constant in J.mol/Kelvin
real(pReal), parameter :: Rgaz = 8.314_pReal
CONTAINS
!****************************************
!* - constitutive_init
!* - constitutive_homogenizedC
!* - constitutive_microstructure
!* - constitutive_LpAndItsTangent
!* - consistutive_dotState
!* - consistutive_postResults
!****************************************
subroutine constitutive_dislobased_init(file)
!**************************************
!* Module initialization *
!**************************************
use prec, only: pInt, pReal
use math, only: math_Mandel3333to66, math_Voigt66to3333, math_mul3x3
use IO
use material
use lattice, only: lattice_sn, lattice_st, lattice_interactionSlipSlip, lattice_initializeStructure
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 7
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) section, maxNinstance, i,j,k,l, output
character(len=64) tag
character(len=1024) line
real(pReal) x,y
maxNinstance = count(phase_constitution == constitutive_dislobased_label)
if (maxNinstance == 0) return
allocate(constitutive_dislobased_sizeDotState(maxNinstance)) ; constitutive_dislobased_sizeDotState = 0_pInt
allocate(constitutive_dislobased_sizeState(maxNinstance)) ; constitutive_dislobased_sizeState = 0_pInt
allocate(constitutive_dislobased_sizePostResults(maxNinstance)); constitutive_dislobased_sizePostResults = 0_pInt
allocate(constitutive_dislobased_output(maxval(phase_Noutput), &
maxNinstance)) ; constitutive_dislobased_output = ''
allocate(constitutive_dislobased_structureName(maxNinstance)) ; constitutive_dislobased_structureName = ''
allocate(constitutive_dislobased_structure(maxNinstance)) ; constitutive_dislobased_structure = 0_pInt
allocate(constitutive_dislobased_Nslip(maxNinstance)) ; constitutive_dislobased_Nslip = 0_pInt
allocate(constitutive_dislobased_C11(maxNinstance)) ; constitutive_dislobased_C11 = 0.0_pReal
allocate(constitutive_dislobased_C12(maxNinstance)) ; constitutive_dislobased_C12 = 0.0_pReal
allocate(constitutive_dislobased_C13(maxNinstance)) ; constitutive_dislobased_C13 = 0.0_pReal
allocate(constitutive_dislobased_C33(maxNinstance)) ; constitutive_dislobased_C33 = 0.0_pReal
allocate(constitutive_dislobased_C44(maxNinstance)) ; constitutive_dislobased_C44 = 0.0_pReal
allocate(constitutive_dislobased_Gmod(maxNinstance)) ; constitutive_dislobased_Gmod = 0.0_pReal
allocate(constitutive_dislobased_Cslip_66(6,6,maxNinstance)) ; constitutive_dislobased_Cslip_66 = 0.0_pReal
allocate(constitutive_dislobased_rho0(maxNinstance)) ; constitutive_dislobased_rho0 = 0.0_pReal
allocate(constitutive_dislobased_bg(maxNinstance)) ; constitutive_dislobased_bg = 0.0_pReal
allocate(constitutive_dislobased_Qedge(maxNinstance)) ; constitutive_dislobased_Qedge = 0.0_pReal
allocate(constitutive_dislobased_Qsd(maxNinstance)) ; constitutive_dislobased_Qsd = 0.0_pReal
allocate(constitutive_dislobased_D0(maxNinstance)) ; constitutive_dislobased_D0 = 0.0_pReal
allocate(constitutive_dislobased_c1(maxNinstance)) ; constitutive_dislobased_c1 = 0.0_pReal
allocate(constitutive_dislobased_c2(maxNinstance)) ; constitutive_dislobased_c2 = 0.0_pReal
allocate(constitutive_dislobased_c3(maxNinstance)) ; constitutive_dislobased_c3 = 0.0_pReal
allocate(constitutive_dislobased_c4(maxNinstance)) ; constitutive_dislobased_c4 = 0.0_pReal
allocate(constitutive_dislobased_c5(maxNinstance)) ; constitutive_dislobased_c5 = 0.0_pReal
allocate(constitutive_dislobased_c6(maxNinstance)) ; constitutive_dislobased_c6 = 0.0_pReal
allocate(constitutive_dislobased_c7(maxNinstance)) ; constitutive_dislobased_c7 = 0.0_pReal
allocate(constitutive_dislobased_c8(maxNinstance)) ; constitutive_dislobased_c8 = 0.0_pReal
allocate(constitutive_dislobased_CoverA(maxNinstance)) ; constitutive_dislobased_CoverA = 0.0_pReal
allocate(constitutive_dislobased_SlipIntCoeff(6,maxNinstance)) ; constitutive_dislobased_SlipIntCoeff = 0.0_pReal
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= 'phase') ! wind forward to <phase>
read(file,'(a1024)',END=100) line
enddo
do ! read thru sections of phase part
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
output = 0 ! reset output counter
endif
if (section > 0 .and. phase_constitution(section) == constitutive_dislobased_label) then ! one of my sections
i = phase_constitutionInstance(section) ! which instance of my constitution is present phase
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('(output)')
output = output + 1
constitutive_dislobased_output(output,i) = IO_lc(IO_stringValue(line,positions,2))
case ('lattice_structure')
constitutive_dislobased_structureName(i) = IO_lc(IO_stringValue(line,positions,2))
case ('covera_ratio')
constitutive_dislobased_CoverA(i) = IO_floatValue(line,positions,2)
case ('nslip')
constitutive_dislobased_Nslip(i) = IO_intValue(line,positions,2)
case ('c11')
constitutive_dislobased_C11(i) = IO_floatValue(line,positions,2)
case ('c12')
constitutive_dislobased_C12(i) = IO_floatValue(line,positions,2)
case ('c13')
constitutive_dislobased_C13(i) = IO_floatValue(line,positions,2)
case ('c33')
constitutive_dislobased_C33(i) = IO_floatValue(line,positions,2)
case ('c44')
constitutive_dislobased_C44(i) = IO_floatValue(line,positions,2)
case ('rho0')
constitutive_dislobased_rho0(i) = IO_floatValue(line,positions,2)
case ('burgers')
constitutive_dislobased_bg(i) = IO_floatValue(line,positions,2)
case ('qedge')
constitutive_dislobased_Qedge(i) = IO_floatValue(line,positions,2)
case ('qsd')
constitutive_dislobased_Qsd(i) = IO_floatValue(line,positions,2)
case ('diff0')
constitutive_dislobased_D0(i) = IO_floatValue(line,positions,2)
case ('c1')
constitutive_dislobased_c1(i) = IO_floatValue(line,positions,2)
case ('c2')
constitutive_dislobased_c2(i) = IO_floatValue(line,positions,2)
case ('c3')
constitutive_dislobased_c3(i) = IO_floatValue(line,positions,2)
case ('c4')
constitutive_dislobased_c4(i) = IO_floatValue(line,positions,2)
case ('c5')
constitutive_dislobased_c5(i) = IO_floatValue(line,positions,2)
case ('c6')
constitutive_dislobased_c6(i) = IO_floatValue(line,positions,2)
case ('c7')
constitutive_dislobased_c7(i) = IO_floatValue(line,positions,2)
case ('c8')
constitutive_dislobased_c8(i) = IO_floatValue(line,positions,2)
case ('interaction_coefficients')
forall (j=2:min(7,positions(1))) &
constitutive_dislobased_SlipIntCoeff(j-1,i) = IO_floatValue(line,positions,j)
end select
endif
enddo
100 do i = 1,maxNinstance
constitutive_dislobased_structure(i) = lattice_initializeStructure(constitutive_dislobased_structureName(i), &
constitutive_dislobased_CoverA(i))
! sanity checks
if (constitutive_dislobased_structure(i) < 1) call IO_error(201)
if (constitutive_dislobased_Nslip(i) < 1) call IO_error(202)
if (constitutive_dislobased_rho0(i) < 0.0_pReal) call IO_error(220)
if (constitutive_dislobased_bg(i) <= 0.0_pReal) call IO_error(221)
if (constitutive_dislobased_Qedge(i) <= 0.0_pReal) call IO_error(222)
if (constitutive_dislobased_Qsd(i) <= 0.0_pReal) call IO_error(223)
if (constitutive_dislobased_D0(i) <= 0.0_pReal) call IO_error(224)
enddo
allocate(constitutive_dislobased_Iparallel(maxval(constitutive_dislobased_Nslip),&
maxval(constitutive_dislobased_Nslip),&
maxNinstance))
allocate(constitutive_dislobased_Iforest(maxval(constitutive_dislobased_Nslip),&
maxval(constitutive_dislobased_Nslip),&
maxNinstance))
do i = 1,maxNinstance
constitutive_dislobased_sizeDotState(i) = constitutive_dislobased_Nslip(i)
constitutive_dislobased_sizeState(i) = 8*constitutive_dislobased_Nslip(i)
do j = 1,maxval(phase_Noutput)
select case(constitutive_dislobased_output(j,i))
case('dislodensity')
constitutive_dislobased_sizePostResults(i) = &
constitutive_dislobased_sizePostResults(i) + constitutive_dislobased_Nslip(i)
case('rateofshear')
constitutive_dislobased_sizePostResults(i) = &
constitutive_dislobased_sizePostResults(i) + constitutive_dislobased_Nslip(i)
end select
enddo
constitutive_dislobased_Gmod(i) = constitutive_dislobased_C44(i)
select case (constitutive_dislobased_structure(i))
case(1:2) ! cubic(s)
forall(k=1:3)
forall(j=1:3) &
constitutive_dislobased_Cslip_66(k,j,i) = constitutive_dislobased_C12(i)
constitutive_dislobased_Cslip_66(k,k,i) = constitutive_dislobased_C11(i)
constitutive_dislobased_Cslip_66(k+3,k+3,i) = constitutive_dislobased_C44(i)
end forall
case(3:) ! all hex
constitutive_dislobased_Cslip_66(1,1,i) = constitutive_dislobased_C11(i)
constitutive_dislobased_Cslip_66(2,2,i) = constitutive_dislobased_C11(i)
constitutive_dislobased_Cslip_66(3,3,i) = constitutive_dislobased_C33(i)
constitutive_dislobased_Cslip_66(1,2,i) = constitutive_dislobased_C12(i)
constitutive_dislobased_Cslip_66(2,1,i) = constitutive_dislobased_C12(i)
constitutive_dislobased_Cslip_66(1,3,i) = constitutive_dislobased_C13(i)
constitutive_dislobased_Cslip_66(3,1,i) = constitutive_dislobased_C13(i)
constitutive_dislobased_Cslip_66(2,3,i) = constitutive_dislobased_C13(i)
constitutive_dislobased_Cslip_66(3,2,i) = constitutive_dislobased_C13(i)
constitutive_dislobased_Cslip_66(4,4,i) = constitutive_dislobased_C44(i)
constitutive_dislobased_Cslip_66(5,5,i) = constitutive_dislobased_C44(i)
constitutive_dislobased_Cslip_66(6,6,i) = 0.5_pReal*(constitutive_dislobased_C11(i)- &
constitutive_dislobased_C12(i))
end select
constitutive_dislobased_Cslip_66(:,:,i) = &
math_Mandel3333to66(math_Voigt66to3333(constitutive_dislobased_Cslip_66(:,:,i)))
!* Construction of the hardening matrices
!* Iteration over the systems
do j = 1,constitutive_dislobased_Nslip(i)
do k = 1,constitutive_dislobased_Nslip(i)
!* Projection of the dislocation *
x = math_mul3x3(lattice_sn(:,j,i),lattice_st(:,k,i))
y = 1.0_pReal-x**(2.0_pReal)
!* Interaction matrix *
constitutive_dislobased_Iforest(j,k,i) = abs(x)*&
constitutive_dislobased_SlipIntCoeff(lattice_interactionSlipSlip(j,k,constitutive_dislobased_structure(i)),i)
if (y>0.0_pReal) &
constitutive_dislobased_Iparallel(j,k,i) = sqrt(y)*&
constitutive_dislobased_SlipIntCoeff(lattice_interactionSlipSlip(j,k,constitutive_dislobased_structure(i)),i)
enddo
enddo
enddo
return
end subroutine
function constitutive_dislobased_stateInit(myInstance)
!*********************************************************************
!* initial microstructural state *
!*********************************************************************
use prec, only: pReal,pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: myInstance
real(pReal), dimension(constitutive_dislobased_Nslip(myInstance)) :: constitutive_dislobased_stateInit
constitutive_dislobased_stateInit = constitutive_dislobased_rho0(myInstance)
return
end function
function constitutive_dislobased_homogenizedC(state,ipc,ip,el)
!*********************************************************************
!* homogenized elacticity matrix *
!* INPUT: *
!* - state : state variables *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
integer(pInt) matID
real(pReal), dimension(6,6) :: constitutive_dislobased_homogenizedC
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
constitutive_dislobased_homogenizedC = constitutive_dislobased_Cslip_66(:,:,matID)
return
end function
subroutine constitutive_dislobased_microstructure(Temperature,state,ipc,ip,el)
!*********************************************************************
!* calculate derived quantities from state (not used here) *
!* INPUT: *
!* - Tp : temperature *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el,matID,n,i
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_dislobased_Nslip(matID)
!* Quantities derived from state - slip
!* State: 1 : n rho
!* n+1 : 2n rho_f
!* 2n+1 : 3n rho_p
!* 3n+1 : 4n passing stress
!* 4n+1 : 5n jump width
!* 5n+1 : 6n activation volume
!* 6n+1 : 7n rho_m
!* 7n+1 : 8n g0_slip
!$OMP CRITICAL (evilmatmul)
state(ipc,ip,el)%p((n+1):(2*n)) = matmul(constitutive_dislobased_Iforest (1:n,1:n,matID),state(ipc,ip,el)%p(1:n))
state(ipc,ip,el)%p((2*n+1):(3*n)) = matmul(constitutive_dislobased_Iparallel(1:n,1:n,matID),state(ipc,ip,el)%p(1:n))
!$OMP END CRITICAL (evilmatmul)
do i=1,n
state(ipc,ip,el)%p(3*n+i) = &
constitutive_dislobased_c1(matID)*constitutive_dislobased_Gmod(matID)*&
constitutive_dislobased_bg(matID)*sqrt(state(ipc,ip,el)%p(2*n+i))
state(ipc,ip,el)%p(4*n+i) = &
constitutive_dislobased_c2(matID)/sqrt(state(ipc,ip,el)%p(n+i))
state(ipc,ip,el)%p(5*n+i) = &
constitutive_dislobased_c3(matID)*state(ipc,ip,el)%p(4*n+i)*constitutive_dislobased_bg(matID)**2.0_pReal
state(ipc,ip,el)%p(6*n+i) = &
(2.0_pReal*kB*Temperature*sqrt(state(ipc,ip,el)%p(2*n+i)))/&
(constitutive_dislobased_c1(matID)*constitutive_dislobased_c3(matID)*constitutive_dislobased_Gmod(matID)*&
state(ipc,ip,el)%p(4*n+i)*constitutive_dislobased_bg(matID)**3.0_pReal)
state(ipc,ip,el)%p(7*n+i) = &
state(ipc,ip,el)%p(6*n+i)*constitutive_dislobased_bg(matID)*attack_frequency*state(ipc,ip,el)%p(4*n+i)*&
exp(-constitutive_dislobased_Qedge(matID)/(kB*Temperature))
enddo
end subroutine
subroutine constitutive_dislobased_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* plastic velocity gradient and its tangent *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - Lp : plastic velocity gradient *
!* - dLp_dTstar : derivative of Lp (4th-rank tensor) *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_Plain3333to99, math_mul6x6
use lattice, only: lattice_Sslip,lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID,i,k,l,m,n
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(3,3) :: Lp
real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333
real(pReal), dimension(9,9) :: dLp_dTstar
real(pReal), dimension(constitutive_dislobased_Nslip(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
gdot_slip,dgdot_dtauslip,tau_slip
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_dislobased_Nslip(matID)
!* Calculation of Lp
Lp = 0.0_pReal
gdot_slip = 0.0_pReal
do i = 1,constitutive_dislobased_Nslip(matID)
tau_slip(i) = math_mul6x6(Tstar_v,lattice_Sslip_v(:,i,constitutive_dislobased_structure(matID)))
if ((abs(tau_slip(i))-state(ipc,ip,el)%p(3*n+i))>0) &
gdot_slip(i) = state(ipc,ip,el)%p(7*n+i)*sign(1.0_pReal,tau_slip(i))*&
sinh(((abs(tau_slip(i))-state(ipc,ip,el)%p(3*n+i))*state(ipc,ip,el)%p(5*n+i))/(kB*Temperature))
Lp = Lp + gdot_slip(i)*lattice_Sslip(:,:,i,constitutive_dislobased_structure(matID))
enddo
!* Calculation of the tangent of Lp
dLp_dTstar3333 = 0.0_pReal
dLp_dTstar = 0.0_pReal
dgdot_dtauslip = 0.0_pReal
do i = 1,constitutive_dislobased_Nslip(matID)
if ((abs(tau_slip(i))-state(ipc,ip,el)%p(3*n+i))>0) &
dgdot_dtauslip(i) = (state(ipc,ip,el)%p(7*n+i)*state(ipc,ip,el)%p(5*n+i))/(kB*Temperature)*&
cosh(((abs(tau_slip(i))-state(ipc,ip,el)%p(3*n+i))*state(ipc,ip,el)%p(5*n+i))/(kB*Temperature))
forall (k=1:3,l=1:3,m=1:3,n=1:3) &
dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + &
dgdot_dtauslip(i)*lattice_Sslip(k,l,i,constitutive_dislobased_structure(matID))* &
lattice_Sslip(m,n,i,constitutive_dislobased_structure(matID))
enddo
dLp_dTstar = math_Plain3333to99(dLp_dTstar3333)
return
end subroutine
function constitutive_dislobased_dotState(Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* rate of change of microstructure *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - constitutive_dotState : evolution of state variable *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID,i,n
real(pReal) Temperature,tau_slip,gdot_slip,locks,athermal_recovery,thermal_recovery
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(constitutive_dislobased_Nslip(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
constitutive_dislobased_dotState
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_dislobased_Nslip(matID)
!* Dislocation density evolution
constitutive_dislobased_dotState = 0.0_pReal
do i = 1,n
tau_slip = dot_product(Tstar_v,lattice_Sslip_v(:,i,constitutive_dislobased_structure(matID)))
if (abs(tau_slip) > state(ipc,ip,el)%p(3*n+i)) then
gdot_slip = state(ipc,ip,el)%p(7*n+i)*sign(1.0_pReal,tau_slip)*&
sinh(((abs(tau_slip)-state(ipc,ip,el)%p(3*n+i))*state(ipc,ip,el)%p(5*n+i))/(kB*Temperature))
locks = (sqrt(state(ipc,ip,el)%p(n+i))*abs(gdot_slip))/&
(constitutive_dislobased_c4(matID)*constitutive_dislobased_bg(matID))
athermal_recovery = constitutive_dislobased_c7(matID)*state(ipc,ip,el)%p(i)*abs(gdot_slip)
!thermal_recovery = constitutive_dislobased_c8(matID)*abs(tau_slip)*state(ipc,ip,el)%p(i)**(2.0_pReal)*&
! ((constitutive_dislobased_D0(matID)*constitutive_dislobased_bg(matID)**(3.0_pReal))/&
! (kB*Temperature))*exp(-constitutive_dislobased_Qsd(matID)/(kB*Temperature))
constitutive_dislobased_dotState(i) = locks - athermal_recovery
endif
enddo
return
end function
pure function constitutive_dislobased_postResults(Tstar_v,Temperature,dt,state,ipc,ip,el)
!*********************************************************************
!* return array of constitutive results *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - dt : current time increment *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_mul6x6
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance,phase_Noutput
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
real(pReal), intent(in) :: dt,Temperature
real(pReal), dimension(6), intent(in) :: Tstar_v
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: state
integer(pInt) matID,o,i,c,n
real(pReal) tau_slip, active_rate
real(pReal), dimension(constitutive_dislobased_sizePostResults(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
constitutive_dislobased_postResults
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_dislobased_Nslip(matID)
c = 0_pInt
constitutive_dislobased_postResults = 0.0_pReal
do o = 1,phase_Noutput(material_phase(ipc,ip,el))
select case(constitutive_dislobased_output(o,matID))
case ('dislodensity')
constitutive_dislobased_postResults(c+1:c+n) = state(ipc,ip,el)%p(1:n)
c = c + n
case ('rateofshear')
do i = 1,n
tau_slip = math_mul6x6(Tstar_v,lattice_Sslip_v(:,i,constitutive_dislobased_structure(matID)))
if ((abs(tau_slip)-state(ipc,ip,el)%p(3*n+i))>0) then
constitutive_dislobased_postResults(c+i) = state(ipc,ip,el)%p(7*n+i)*sign(1.0_pReal,tau_slip)*&
sinh(((abs(tau_slip)-state(ipc,ip,el)%p(3*n+i))*state(ipc,ip,el)%p(5*n+i))/(kB*Temperature))
else
constitutive_dislobased_postResults(c+i) = 0.0_pReal
endif
enddo
c = c + n
end select
enddo
return
end function
END MODULE

406
patch/subroutine/constitutive_j2.f90 Normal file
View File

@ -0,0 +1,406 @@
!*****************************************************
!* Module: CONSTITUTIVE_J2 *
!*****************************************************
!* contains: *
!* - constitutive equations *
!* - parameters definition *
!*****************************************************
! [Alu]
! constitution j2
! (output) flowstress
! (output) strainrate
! c11 110.9e9 # (3 C11 + 2 C12 + 2 C44) / 5 ... with C44 = C11-C12 !!
! c12 58.34e9 # (1 C11 + 4 C12 - 1 C44) / 5
! taylorfactor 3
! s0 31e6
! gdot0 0.001
! n 20
! h0 75e6
! s_sat 63e6
! w0 2.25
MODULE constitutive_j2
!*** Include other modules ***
use prec, only: pReal,pInt
implicit none
character (len=*), parameter :: constitutive_j2_label = 'j2'
integer(pInt), dimension(:), allocatable :: constitutive_j2_sizeDotState, &
constitutive_j2_sizeState, &
constitutive_j2_sizePostResults
character(len=64), dimension(:,:), allocatable :: constitutive_j2_output
real(pReal), dimension(:), allocatable :: constitutive_j2_C11
real(pReal), dimension(:), allocatable :: constitutive_j2_C12
real(pReal), dimension(:,:,:), allocatable :: constitutive_j2_Cslip_66
!* Visco-plastic constitutive_j2 parameters
real(pReal), dimension(:), allocatable :: constitutive_j2_fTaylor
real(pReal), dimension(:), allocatable :: constitutive_j2_s0
real(pReal), dimension(:), allocatable :: constitutive_j2_gdot0
real(pReal), dimension(:), allocatable :: constitutive_j2_n
real(pReal), dimension(:), allocatable :: constitutive_j2_h0
real(pReal), dimension(:), allocatable :: constitutive_j2_s_sat
real(pReal), dimension(:), allocatable :: constitutive_j2_w0
CONTAINS
!****************************************
!* - constitutive_j2_init
!* - constitutive_j2_stateInit
!* - constitutive_j2_homogenizedC
!* - constitutive_j2_microstructure
!* - constitutive_j2_LpAndItsTangent
!* - consistutive_j2_dotState
!* - consistutive_j2_postResults
!****************************************
subroutine constitutive_j2_init(file)
!**************************************
!* Module initialization *
!**************************************
use prec, only: pInt, pReal
use math, only: math_Mandel3333to66, math_Voigt66to3333
use IO
use material
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 7
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) section, maxNinstance, i,j,k,l, output
character(len=64) tag
character(len=1024) line
maxNinstance = count(phase_constitution == constitutive_j2_label)
if (maxNinstance == 0) return
allocate(constitutive_j2_sizeDotState(maxNinstance)) ; constitutive_j2_sizeDotState = 0_pInt
allocate(constitutive_j2_sizeState(maxNinstance)) ; constitutive_j2_sizeState = 0_pInt
allocate(constitutive_j2_sizePostResults(maxNinstance)); constitutive_j2_sizePostResults = 0_pInt
allocate(constitutive_j2_output(maxval(phase_Noutput), &
maxNinstance)) ; constitutive_j2_output = ''
allocate(constitutive_j2_C11(maxNinstance)) ; constitutive_j2_C11 = 0.0_pReal
allocate(constitutive_j2_C12(maxNinstance)) ; constitutive_j2_C12 = 0.0_pReal
allocate(constitutive_j2_Cslip_66(6,6,maxNinstance)) ; constitutive_j2_Cslip_66 = 0.0_pReal
allocate(constitutive_j2_fTaylor(maxNinstance)) ; constitutive_j2_fTaylor = 0.0_pReal
allocate(constitutive_j2_s0(maxNinstance)) ; constitutive_j2_s0 = 0.0_pReal
allocate(constitutive_j2_gdot0(maxNinstance)) ; constitutive_j2_gdot0 = 0.0_pReal
allocate(constitutive_j2_n(maxNinstance)) ; constitutive_j2_n = 0.0_pReal
allocate(constitutive_j2_h0(maxNinstance)) ; constitutive_j2_h0 = 0.0_pReal
allocate(constitutive_j2_s_sat(maxNinstance)) ; constitutive_j2_s_sat = 0.0_pReal
allocate(constitutive_j2_w0(maxNinstance)) ; constitutive_j2_w0 = 0.0_pReal
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= 'phase') ! wind forward to <phase>
read(file,'(a1024)',END=100) line
enddo
do ! read thru sections of phase part
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
output = 0 ! reset output counter
endif
if (section > 0 .and. phase_constitution(section) == constitutive_j2_label) then ! one of my sections
i = phase_constitutionInstance(section) ! which instance of my constitution is present phase
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('(output)')
output = output + 1
constitutive_j2_output(output,i) = IO_lc(IO_stringValue(line,positions,2))
case ('c11')
constitutive_j2_C11(i) = IO_floatValue(line,positions,2)
case ('c12')
constitutive_j2_C12(i) = IO_floatValue(line,positions,2)
case ('s0')
constitutive_j2_s0(i) = IO_floatValue(line,positions,2)
case ('gdot0')
constitutive_j2_gdot0(i) = IO_floatValue(line,positions,2)
case ('n')
constitutive_j2_n(i) = IO_floatValue(line,positions,2)
case ('h0')
constitutive_j2_h0(i) = IO_floatValue(line,positions,2)
case ('s_sat')
constitutive_j2_s_sat(i) = IO_floatValue(line,positions,2)
case ('w0')
constitutive_j2_w0(i) = IO_floatValue(line,positions,2)
case ('taylorfactor')
constitutive_j2_fTaylor(i) = IO_floatValue(line,positions,2)
end select
endif
enddo
100 do i = 1,maxNinstance ! sanity checks
if (constitutive_j2_s0(i) < 0.0_pReal) call IO_error(203)
if (constitutive_j2_gdot0(i) <= 0.0_pReal) call IO_error(204)
if (constitutive_j2_n(i) <= 0.0_pReal) call IO_error(205)
if (constitutive_j2_h0(i) <= 0.0_pReal) call IO_error(206)
if (constitutive_j2_s_sat(i) <= 0.0_pReal) call IO_error(207)
if (constitutive_j2_w0(i) <= 0.0_pReal) call IO_error(208)
if (constitutive_j2_fTaylor(i) <= 0.0_pReal) call IO_error(240)
enddo
do i = 1,maxNinstance
constitutive_j2_sizeDotState(i) = 1
constitutive_j2_sizeState(i) = 1
do j = 1,maxval(phase_Noutput)
select case(constitutive_j2_output(j,i))
case('flowstress')
constitutive_j2_sizePostResults(i) = &
constitutive_j2_sizePostResults(i) + 1
case('strainrate')
constitutive_j2_sizePostResults(i) = &
constitutive_j2_sizePostResults(i) + 1
end select
enddo
forall(k=1:3)
forall(j=1:3) &
constitutive_j2_Cslip_66(k,j,i) = constitutive_j2_C12(i)
constitutive_j2_Cslip_66(k,k,i) = constitutive_j2_C11(i)
constitutive_j2_Cslip_66(k+3,k+3,i) = 0.5_pReal*(constitutive_j2_C11(i)-constitutive_j2_C12(i))
end forall
constitutive_j2_Cslip_66(:,:,i) = &
math_Mandel3333to66(math_Voigt66to3333(constitutive_j2_Cslip_66(:,:,i)))
enddo
return
end subroutine
function constitutive_j2_stateInit(myInstance)
!*********************************************************************
!* initial microstructural state *
!*********************************************************************
use prec, only: pReal,pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: myInstance
real(pReal), dimension(1) :: constitutive_j2_stateInit
constitutive_j2_stateInit = constitutive_j2_s0(myInstance)
return
end function
function constitutive_j2_homogenizedC(state,ipc,ip,el)
!*********************************************************************
!* homogenized elacticity matrix *
!* INPUT: *
!* - state : state variables *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
integer(pInt) matID
real(pReal), dimension(6,6) :: constitutive_j2_homogenizedC
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
constitutive_j2_homogenizedC = constitutive_j2_Cslip_66(:,:,matID)
return
end function
subroutine constitutive_j2_microstructure(Temperature,state,ipc,ip,el)
!*********************************************************************
!* calculate derived quantities from state (not used here) *
!* INPUT: *
!* - Tp : temperature *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el, matID
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
end subroutine
subroutine constitutive_j2_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* plastic velocity gradient and its tangent *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - Lp : plastic velocity gradient *
!* - dLp_dTstar : derivative of Lp (4th-rank tensor) *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_mul6x6,math_Mandel6to33,math_Plain3333to99
use lattice, only: lattice_Sslip,lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID,i,k,l,m,n
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(3,3) :: Tstar33
real(pReal), dimension(3,3) :: Lp
real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333
real(pReal), dimension(9,9) :: dLp_dTstar
real(pReal) norm_Tstar, squarenorm_Tstar, factor
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
Tstar33 = math_Mandel6to33(Tstar_v)
squarenorm_Tstar = math_mul6x6(Tstar_v,Tstar_v)
norm_Tstar = dsqrt(squarenorm_Tstar)
!* Initialization of Lp and dLp_dTstar
Lp = 0.0_pReal
dLp_dTstar = 0.0_pReal
!* for Tstar==0 both Lp and dLp_dTstar are zero (if not n==1)
if (norm_Tstar > 0) then
!* Calculation of Lp
Lp = Tstar33/norm_Tstar*constitutive_j2_gdot0(matID)/constitutive_j2_fTaylor(matID)* &
(dsqrt(1.5_pReal)/constitutive_j2_fTaylor(matID)*norm_Tstar/state(ipc,ip,el)%p(1))**constitutive_j2_n(matID)
!* Calculation of the tangent of Lp
factor = constitutive_j2_gdot0(matID)/constitutive_j2_fTaylor(matID)* &
(dsqrt(1.5_pReal)/ constitutive_j2_fTaylor(matID)/state(ipc,ip,el)%p(1))**constitutive_j2_n(matID) * &
norm_Tstar**(constitutive_j2_n(matID)-1.0_pReal)
dLp_dTstar3333 = 0.0_pReal
forall (k=1:3,l=1:3,m=1:3,n=1:3) &
dLp_dTstar3333(k,l,m,n) = Tstar33(k,l)*Tstar33(m,n) * (constitutive_j2_n(matID)-1.0_pReal)/squarenorm_Tstar
forall (k=1:3,l=1:3) &
dLp_dTstar3333(k,l,k,l) = dLp_dTstar3333(k,l,k,l) + 1.0_pReal
dLp_dTstar = math_Plain3333to99(factor * dLp_dTstar3333)
end if
return
end subroutine
function constitutive_j2_dotState(Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* rate of change of microstructure *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - constitutive_dotState : evolution of state variable *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_mul6x6
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(1) :: constitutive_j2_dotState
real(pReal) norm_Tstar
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
norm_Tstar = dsqrt(math_mul6x6(Tstar_v,Tstar_v))
constitutive_j2_dotState = constitutive_j2_gdot0(matID)/constitutive_j2_fTaylor(matID)* &
(dsqrt(1.5_pReal)/constitutive_j2_fTaylor(matID)*norm_Tstar/state(ipc,ip,el)%p(1))** &
constitutive_j2_n(matID) * &
constitutive_j2_h0(matID)*(1.0_pReal-state(ipc,ip,el)%p(1)/constitutive_j2_s_sat(matID))** &
constitutive_j2_w0(matID)
return
end function
pure function constitutive_j2_postResults(Tstar_v,Temperature,dt,state,ipc,ip,el)
!*********************************************************************
!* return array of constitutive results *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - dt : current time increment *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_mul6x6
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance,phase_Noutput
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
real(pReal), intent(in) :: dt,Temperature
real(pReal), dimension(6), intent(in) :: Tstar_v
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: state
integer(pInt) matID,o,i,c,n
real(pReal) norm_Tstar
real(pReal), dimension(constitutive_j2_sizePostResults(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
constitutive_j2_postResults
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
norm_Tstar = dsqrt(math_mul6x6(Tstar_v,Tstar_v))
c = 0_pInt
constitutive_j2_postResults = 0.0_pReal
do o = 1,phase_Noutput(material_phase(ipc,ip,el))
select case(constitutive_j2_output(o,matID))
case ('flowstress')
constitutive_j2_postResults(c+1) = state(ipc,ip,el)%p(1)
c = c + 1
case ('strainrate')
constitutive_j2_postResults(c+1) = constitutive_j2_gdot0(matID)/constitutive_j2_fTaylor(matID)* &
(dsqrt(1.5_pReal)/constitutive_j2_fTaylor(matID)*norm_Tstar/state(ipc,ip,el)%p(1))** &
constitutive_j2_n(matID)
c = c + 1
end select
enddo
return
end function
END MODULE

482
patch/subroutine/constitutive_phenomenological.f90 Normal file
View File

@ -0,0 +1,482 @@
!*****************************************************
!* Module: CONSTITUTIVE_PHENOMENOLOGICAL *
!*****************************************************
!* contains: *
!* - constitutive equations *
!* - parameters definition *
!*****************************************************
! [Alu]
! constitution phenomenological
! (output) slipresistance
! (output) rateofshear
! lattice_structure 1
! Nslip 12
!
! c11 106.75e9
! c12 60.41e9
! c44 28.34e9
!
! s0_slip 31e6
! gdot0_slip 0.001
! n_slip 20
! h0 75e6
! s_sat 63e6
! w0 2.25
! latent_ratio 1.4
MODULE constitutive_phenomenological
!*** Include other modules ***
use prec, only: pReal,pInt
implicit none
character (len=*), parameter :: constitutive_phenomenological_label = 'phenomenological'
integer(pInt), dimension(:), allocatable :: constitutive_phenomenological_sizeDotState, &
constitutive_phenomenological_sizeState, &
constitutive_phenomenological_sizePostResults
character(len=64), dimension(:,:), allocatable :: constitutive_phenomenological_output
character(len=32), dimension(:), allocatable :: constitutive_phenomenological_structureName
integer(pInt), dimension(:), allocatable :: constitutive_phenomenological_structure
integer(pInt), dimension(:), allocatable :: constitutive_phenomenological_Nslip
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_CoverA
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_C11
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_C12
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_C13
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_C33
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_C44
real(pReal), dimension(:,:,:), allocatable :: constitutive_phenomenological_Cslip_66
!* Visco-plastic constitutive_phenomenological parameters
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_s0_slip
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_gdot0_slip
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_n_slip
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_h0
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_s_sat
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_w0
real(pReal), dimension(:), allocatable :: constitutive_phenomenological_latent
real(pReal), dimension(:,:,:), allocatable :: constitutive_phenomenological_HardeningMatrix
CONTAINS
!****************************************
!* - constitutive_init
!* - constitutive_stateInit
!* - constitutive_homogenizedC
!* - constitutive_microstructure
!* - constitutive_LpAndItsTangent
!* - consistutive_dotState
!* - consistutive_postResults
!****************************************
subroutine constitutive_phenomenological_init(file)
!**************************************
!* Module initialization *
!**************************************
use prec, only: pInt, pReal
use math, only: math_Mandel3333to66, math_Voigt66to3333
use IO
use material
use lattice, only: lattice_initializeStructure
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 7
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) section, maxNinstance, i,j,k, output
character(len=64) tag
character(len=1024) line
maxNinstance = count(phase_constitution == constitutive_phenomenological_label)
if (maxNinstance == 0) return
allocate(constitutive_phenomenological_sizeDotState(maxNinstance)) ; constitutive_phenomenological_sizeDotState = 0_pInt
allocate(constitutive_phenomenological_sizeState(maxNinstance)) ; constitutive_phenomenological_sizeState = 0_pInt
allocate(constitutive_phenomenological_sizePostResults(maxNinstance)); constitutive_phenomenological_sizePostResults = 0_pInt
allocate(constitutive_phenomenological_output(maxval(phase_Noutput), &
maxNinstance)) ; constitutive_phenomenological_output = ''
allocate(constitutive_phenomenological_structureName(maxNinstance)) ; constitutive_phenomenological_structureName = ''
allocate(constitutive_phenomenological_structure(maxNinstance)) ; constitutive_phenomenological_structure = 0_pInt
allocate(constitutive_phenomenological_Nslip(maxNinstance)) ; constitutive_phenomenological_Nslip = 0_pInt
allocate(constitutive_phenomenological_CoverA(maxNinstance)) ; constitutive_phenomenological_CoverA = 0.0_pReal
allocate(constitutive_phenomenological_C11(maxNinstance)) ; constitutive_phenomenological_C11 = 0.0_pReal
allocate(constitutive_phenomenological_C12(maxNinstance)) ; constitutive_phenomenological_C12 = 0.0_pReal
allocate(constitutive_phenomenological_C13(maxNinstance)) ; constitutive_phenomenological_C13 = 0.0_pReal
allocate(constitutive_phenomenological_C33(maxNinstance)) ; constitutive_phenomenological_C33 = 0.0_pReal
allocate(constitutive_phenomenological_C44(maxNinstance)) ; constitutive_phenomenological_C44 = 0.0_pReal
allocate(constitutive_phenomenological_Cslip_66(6,6,maxNinstance)) ; constitutive_phenomenological_Cslip_66 = 0.0_pReal
allocate(constitutive_phenomenological_s0_slip(maxNinstance)) ; constitutive_phenomenological_s0_slip = 0.0_pReal
allocate(constitutive_phenomenological_gdot0_slip(maxNinstance)) ; constitutive_phenomenological_gdot0_slip = 0.0_pReal
allocate(constitutive_phenomenological_n_slip(maxNinstance)) ; constitutive_phenomenological_n_slip = 0.0_pReal
allocate(constitutive_phenomenological_h0(maxNinstance)) ; constitutive_phenomenological_h0 = 0.0_pReal
allocate(constitutive_phenomenological_s_sat(maxNinstance)) ; constitutive_phenomenological_s_sat = 0.0_pReal
allocate(constitutive_phenomenological_w0(maxNinstance)) ; constitutive_phenomenological_w0 = 0.0_pReal
allocate(constitutive_phenomenological_latent(maxNinstance)) ; constitutive_phenomenological_latent = 1.0_pReal
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= 'phase') ! wind forward to <phase>
read(file,'(a1024)',END=100) line
enddo
do ! read thru sections of phase part
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
output = 0 ! reset output counter
endif
if (section > 0 .and. phase_constitution(section) == constitutive_phenomenological_label) then ! one of my sections
i = phase_constitutionInstance(section) ! which instance of my constitution is present phase
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('(output)')
output = output + 1
constitutive_phenomenological_output(output,i) = IO_lc(IO_stringValue(line,positions,2))
case ('lattice_structure')
constitutive_phenomenological_structureName(i) = IO_lc(IO_stringValue(line,positions,2))
case ('nslip')
constitutive_phenomenological_Nslip(i) = IO_intValue(line,positions,2)
case ('covera_ratio')
constitutive_phenomenological_CoverA(i) = IO_floatValue(line,positions,2)
case ('c11')
constitutive_phenomenological_C11(i) = IO_floatValue(line,positions,2)
case ('c12')
constitutive_phenomenological_C12(i) = IO_floatValue(line,positions,2)
case ('c13')
constitutive_phenomenological_C13(i) = IO_floatValue(line,positions,2)
case ('c33')
constitutive_phenomenological_C33(i) = IO_floatValue(line,positions,2)
case ('c44')
constitutive_phenomenological_C44(i) = IO_floatValue(line,positions,2)
case ('s0_slip')
constitutive_phenomenological_s0_slip(i) = IO_floatValue(line,positions,2)
case ('gdot0_slip')
constitutive_phenomenological_gdot0_slip(i) = IO_floatValue(line,positions,2)
case ('n_slip')
constitutive_phenomenological_n_slip(i) = IO_floatValue(line,positions,2)
case ('h0')
constitutive_phenomenological_h0(i) = IO_floatValue(line,positions,2)
case ('s_sat')
constitutive_phenomenological_s_sat(i) = IO_floatValue(line,positions,2)
case ('w0')
constitutive_phenomenological_w0(i) = IO_floatValue(line,positions,2)
case ('latent_ratio')
constitutive_phenomenological_latent(i) = IO_floatValue(line,positions,2)
end select
endif
enddo
100 do i = 1,maxNinstance
constitutive_phenomenological_structure(i) = lattice_initializeStructure(constitutive_phenomenological_structureName(i), &
constitutive_phenomenological_CoverA(i)) ! sanity checks
if (constitutive_phenomenological_structure(i) < 1 .or. &
constitutive_phenomenological_structure(i) > 3) call IO_error(201)
if (constitutive_phenomenological_Nslip(i) < 1) call IO_error(202)
if (constitutive_phenomenological_s0_slip(i) < 0.0_pReal) call IO_error(203)
if (constitutive_phenomenological_gdot0_slip(i) <= 0.0_pReal) call IO_error(204)
if (constitutive_phenomenological_n_slip(i) <= 0.0_pReal) call IO_error(205)
if (constitutive_phenomenological_h0(i) <= 0.0_pReal) call IO_error(206)
if (constitutive_phenomenological_s_sat(i) <= 0.0_pReal) call IO_error(207)
if (constitutive_phenomenological_w0(i) <= 0.0_pReal) call IO_error(208)
if (constitutive_phenomenological_latent(i) < 0.0_pReal) call IO_error(209)
enddo
allocate(constitutive_phenomenological_hardeningMatrix(maxval(constitutive_phenomenological_Nslip),&
maxval(constitutive_phenomenological_Nslip),&
maxNinstance))
do i = 1,maxNinstance
constitutive_phenomenological_sizeDotState(i) = constitutive_phenomenological_Nslip(i)
constitutive_phenomenological_sizeState(i) = constitutive_phenomenological_Nslip(i)
do j = 1,maxval(phase_Noutput)
select case(constitutive_phenomenological_output(j,i))
case('slipresistance')
constitutive_phenomenological_sizePostResults(i) = &
constitutive_phenomenological_sizePostResults(i) + constitutive_phenomenological_Nslip(i)
case('rateofshear')
constitutive_phenomenological_sizePostResults(i) = &
constitutive_phenomenological_sizePostResults(i) + constitutive_phenomenological_Nslip(i)
end select
enddo
select case (constitutive_phenomenological_structure(i))
case(1:2) ! cubic(s)
forall(k=1:3)
forall(j=1:3) &
constitutive_phenomenological_Cslip_66(k,j,i) = constitutive_phenomenological_C12(i)
constitutive_phenomenological_Cslip_66(k,k,i) = constitutive_phenomenological_C11(i)
constitutive_phenomenological_Cslip_66(k+3,k+3,i) = constitutive_phenomenological_C44(i)
end forall
case(3) ! hcp
constitutive_phenomenological_Cslip_66(1,1,i) = constitutive_phenomenological_C11(i)
constitutive_phenomenological_Cslip_66(2,2,i) = constitutive_phenomenological_C11(i)
constitutive_phenomenological_Cslip_66(3,3,i) = constitutive_phenomenological_C33(i)
constitutive_phenomenological_Cslip_66(1,2,i) = constitutive_phenomenological_C12(i)
constitutive_phenomenological_Cslip_66(2,1,i) = constitutive_phenomenological_C12(i)
constitutive_phenomenological_Cslip_66(1,3,i) = constitutive_phenomenological_C13(i)
constitutive_phenomenological_Cslip_66(3,1,i) = constitutive_phenomenological_C13(i)
constitutive_phenomenological_Cslip_66(2,3,i) = constitutive_phenomenological_C13(i)
constitutive_phenomenological_Cslip_66(3,2,i) = constitutive_phenomenological_C13(i)
constitutive_phenomenological_Cslip_66(4,4,i) = constitutive_phenomenological_C44(i)
constitutive_phenomenological_Cslip_66(5,5,i) = constitutive_phenomenological_C44(i)
constitutive_phenomenological_Cslip_66(6,6,i) = 0.5_pReal*(constitutive_phenomenological_C11(i)- &
constitutive_phenomenological_C12(i))
end select
constitutive_phenomenological_Cslip_66(:,:,i) = &
math_Mandel3333to66(math_Voigt66to3333(constitutive_phenomenological_Cslip_66(:,:,i)))
constitutive_phenomenological_hardeningMatrix(:,:,i) = constitutive_phenomenological_latent(i)
forall (j = 1:constitutive_phenomenological_Nslip(i)) &
constitutive_phenomenological_hardeningMatrix(j,j,i) = 1.0_pReal
enddo
return
end subroutine
function constitutive_phenomenological_stateInit(myInstance)
!*********************************************************************
!* initial microstructural state *
!*********************************************************************
use prec, only: pReal,pInt
implicit none
!* Definition of variables
integer(pInt), intent(in) :: myInstance
real(pReal), dimension(constitutive_phenomenological_Nslip(myInstance)) :: constitutive_phenomenological_stateInit
constitutive_phenomenological_stateInit = constitutive_phenomenological_s0_slip(myInstance)
return
end function
function constitutive_phenomenological_homogenizedC(state,ipc,ip,el)
!*********************************************************************
!* homogenized elacticity matrix *
!* INPUT: *
!* - state : state variables *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
integer(pInt) matID
real(pReal), dimension(6,6) :: constitutive_phenomenological_homogenizedC
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
constitutive_phenomenological_homogenizedC = constitutive_phenomenological_Cslip_66(:,:,matID)
return
end function
subroutine constitutive_phenomenological_microstructure(Temperature,state,ipc,ip,el)
!*********************************************************************
!* calculate derived quantities from state (not used here) *
!* INPUT: *
!* - Tp : temperature *
!* - ipc : component-ID of current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el, matID
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
end subroutine
subroutine constitutive_phenomenological_LpAndItsTangent(Lp,dLp_dTstar,Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* plastic velocity gradient and its tangent *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - Lp : plastic velocity gradient *
!* - dLp_dTstar : derivative of Lp (4th-rank tensor) *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use math, only: math_Plain3333to99
use lattice, only: lattice_Sslip,lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID,i,k,l,m,n
real(pReal) Temperature
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(3,3) :: Lp
real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333
real(pReal), dimension(9,9) :: dLp_dTstar
real(pReal), dimension(constitutive_phenomenological_Nslip(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
gdot_slip,dgdot_dtauslip,tau_slip
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
!* Calculation of Lp
Lp = 0.0_pReal
do i = 1,constitutive_phenomenological_Nslip(matID)
tau_slip(i) = dot_product(Tstar_v,lattice_Sslip_v(:,i,constitutive_phenomenological_structure(matID)))
gdot_slip(i) = constitutive_phenomenological_gdot0_slip(matID)*(abs(tau_slip(i))/state(ipc,ip,el)%p(i))**&
constitutive_phenomenological_n_slip(matID)*sign(1.0_pReal,tau_slip(i))
Lp = Lp + gdot_slip(i)*lattice_Sslip(:,:,i,constitutive_phenomenological_structure(matID))
enddo
!* Calculation of the tangent of Lp
dLp_dTstar3333 = 0.0_pReal
dLp_dTstar = 0.0_pReal
do i = 1,constitutive_phenomenological_Nslip(matID)
dgdot_dtauslip(i) = constitutive_phenomenological_gdot0_slip(matID)*(abs(tau_slip(i))/state(ipc,ip,el)%p(i))**&
(constitutive_phenomenological_n_slip(matID)-1.0_pReal)*&
constitutive_phenomenological_n_slip(matID)/state(ipc,ip,el)%p(i)
forall (k=1:3,l=1:3,m=1:3,n=1:3) &
dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + &
dgdot_dtauslip(i)*lattice_Sslip(k,l,i,constitutive_phenomenological_structure(matID))* &
lattice_Sslip(m,n,i,constitutive_phenomenological_structure(matID))
enddo
dLp_dTstar = math_Plain3333to99(dLp_dTstar3333)
return
end subroutine
function constitutive_phenomenological_dotState(Tstar_v,Temperature,state,ipc,ip,el)
!*********************************************************************
!* rate of change of microstructure *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!* OUTPUT: *
!* - constitutive_dotState : evolution of state variable *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase, phase_constitutionInstance
implicit none
!* Definition of variables
integer(pInt) ipc,ip,el
integer(pInt) matID,i,n
real(pReal) Temperature,tau_slip,gdot_slip
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: state
real(pReal), dimension(6) :: Tstar_v
real(pReal), dimension(constitutive_phenomenological_Nslip(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
constitutive_phenomenological_dotState,self_hardening
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_phenomenological_Nslip(matID)
!* Self-Hardening of each system
do i = 1,n
tau_slip = dot_product(Tstar_v,lattice_Sslip_v(:,i,constitutive_phenomenological_structure(matID)))
gdot_slip = constitutive_phenomenological_gdot0_slip(matID)*(abs(tau_slip)/state(ipc,ip,el)%p(i))**&
constitutive_phenomenological_n_slip(matID)*sign(1.0_pReal,tau_slip)
self_hardening(i) = constitutive_phenomenological_h0(matID)*(1.0_pReal-state(ipc,ip,el)%p(i)/&
constitutive_phenomenological_s_sat(matID))**constitutive_phenomenological_w0(matID)*abs(gdot_slip)
enddo
!$OMP CRITICAL (evilmatmul)
constitutive_phenomenological_dotState = matmul(constitutive_phenomenological_hardeningMatrix(1:n,1:n,matID),self_hardening)
!$OMP END CRITICAL (evilmatmul)
return
end function
pure function constitutive_phenomenological_postResults(Tstar_v,Temperature,dt,state,ipc,ip,el)
!*********************************************************************
!* return array of constitutive results *
!* INPUT: *
!* - Tstar_v : 2nd Piola Kirchhoff stress tensor (Mandel) *
!* - dt : current time increment *
!* - ipc : component-ID at current integration point *
!* - ip : current integration point *
!* - el : current element *
!*********************************************************************
use prec, only: pReal,pInt,p_vec
use lattice, only: lattice_Sslip_v
use mesh, only: mesh_NcpElems,mesh_maxNips
use material, only: homogenization_maxNgrains,material_phase,phase_constitutionInstance,phase_Noutput
implicit none
!* Definition of variables
integer(pInt), intent(in) :: ipc,ip,el
real(pReal), intent(in) :: dt,Temperature
real(pReal), dimension(6), intent(in) :: Tstar_v
type(p_vec), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: state
integer(pInt) matID,o,i,c,n
real(pReal) tau_slip
real(pReal), dimension(constitutive_phenomenological_sizePostResults(phase_constitutionInstance(material_phase(ipc,ip,el)))) :: &
constitutive_phenomenological_postResults
matID = phase_constitutionInstance(material_phase(ipc,ip,el))
n = constitutive_phenomenological_Nslip(matID)
c = 0_pInt
constitutive_phenomenological_postResults = 0.0_pReal
do o = 1,phase_Noutput(material_phase(ipc,ip,el))
select case(constitutive_phenomenological_output(o,matID))
case ('slipresistance')
constitutive_phenomenological_postResults(c+1:c+n) = state(ipc,ip,el)%p(1:n)
c = c + n
case ('rateofshear')
do i = 1,n
tau_slip = dot_product(Tstar_v,lattice_Sslip_v(:,i,constitutive_phenomenological_structure(matID)))
constitutive_phenomenological_postResults(c+i) = sign(1.0_pReal,tau_slip)*constitutive_phenomenological_gdot0_slip(matID)*&
(abs(tau_slip)/state(ipc,ip,el)%p(i))**&
constitutive_phenomenological_n_slip(matID)
enddo
c = c + n
end select
enddo
return
end function
END MODULE

24
patch/subroutine/creeps2007r1 Normal file
View File

@ -0,0 +1,24 @@
! reformated to free format
!***********************************************************************
!
! File: creeps.cmn
!
! MSC.Marc include file
!
real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept
integer(pInt) icptim,icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,&
icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst
!
common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst
!
! time_beg_lcase time at the beginning of the current load case
! time_beg_inc time at the beginning of the current increment
! fractol fraction of loadcase or increment time when we
! consider it to be finished
! time_beg_pst time corresponding to first increment to be
! read in from thermal post file for auto step
!
!***********************************************************************

28
patch/subroutine/creeps2008r1 Normal file
View File

@ -0,0 +1,28 @@
! reformated to free format
!***********************************************************************
!
! File: creeps.cmn
!
! MSC.Marc include file
!
real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept
integer(pInt) icptim,icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,&
icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst
!
integer num_creepsr,num_creepsi,num_creeps2r
parameter(num_creepsr=40)
parameter(num_creepsi=18)
parameter(num_creeps2r=4)
common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst
!
! time_beg_lcase time at the beginning of the current load case
! time_beg_inc time at the beginning of the current increment
! fractol fraction of loadcase or increment time when we
! consider it to be finished
! time_beg_pst time corresponding to first increment to be
! read in from thermal post file for auto step
!
!***********************************************************************

82
patch/subroutine/debug.f90 Normal file
View File

@ -0,0 +1,82 @@
!##############################################################
MODULE debug
!##############################################################
use prec
implicit none
integer(pInt), dimension(nCutback+1) :: debug_cutbackDistribution = 0_pInt
integer(pInt), dimension(nInner) :: debug_InnerLoopDistribution = 0_pInt
integer(pInt), dimension(nOuter) :: debug_OuterLoopDistribution = 0_pInt
integer(pLongInt) :: debug_cumLpTicks = 0_pInt
integer(pLongInt) :: debug_cumDotStateTicks = 0_pInt
integer(pInt) :: debug_cumLpCalls = 0_pInt
integer(pInt) :: debug_cumDotStateCalls = 0_pInt
logical :: debugger = .false.
logical :: distribution_init = .false.
CONTAINS
!********************************************************************
! write debug statements to standard out
!********************************************************************
SUBROUTINE debug_info()
use prec
implicit none
integer(pInt) i,integral
integer(pLongInt) tickrate
write(6,*)
write(6,*) 'DEBUG Info'
write(6,*)
write(6,'(a33,x,i12)') 'total calls to LpAndItsTangent :',debug_cumLpCalls
if (debug_cumLpCalls > 0_pInt) then
call system_clock(count_rate=tickrate)
write(6,'(a33,x,f12.6)') 'avg CPU time/microsecs per call :',dble(debug_cumLpTicks)/tickrate/1.0e-6_pReal/debug_cumLpCalls
write(6,'(a33,x,i12)') 'total CPU ticks :',debug_cumLpTicks
endif
write(6,*)
write(6,'(a33,x,i12)') 'total calls to dotState :',debug_cumDotStateCalls
if (debug_cumdotStateCalls > 0_pInt) then
call system_clock(count_rate=tickrate)
write(6,'(a33,x,f12.6)') 'avg CPU time/microsecs per call :',&
dble(debug_cumDotStateTicks)/tickrate/1.0e-6_pReal/debug_cumDotStateCalls
write(6,'(a33,x,i12)') 'total CPU ticks :',debug_cumDotStateTicks
endif
write(6,*)
write(6,*) 'distribution_cutback :'
do i=0,nCutback
if (debug_cutbackDistribution(i+1) /= 0) write(6,*) i,debug_cutbackDistribution(i+1)
enddo
write(6,*) 'total',sum(debug_cutbackDistribution)
write(6,*)
integral = 0_pInt
write(6,*) 'distribution_InnerLoop :'
do i=1,nInner
if (debug_InnerLoopDistribution(i) /= 0) then
integral = integral + i*debug_InnerLoopDistribution(i)
write(6,*) i,debug_InnerLoopDistribution(i)
endif
enddo
write(6,*) 'total',sum(debug_InnerLoopDistribution),integral
write(6,*)
integral = 0_pInt
write(6,*) 'distribution_OuterLoop :'
do i=1,nOuter
if (debug_OuterLoopDistribution(i) /= 0) then
integral = integral + i*debug_OuterLoopDistribution(i)
write(6,*) i,debug_OuterLoopDistribution(i)
endif
enddo
write(6,*) 'total',sum(debug_OuterLoopDistribution),integral
write(6,*)
END SUBROUTINE
END MODULE debug

3772
patch/subroutine/documentation/ElementType/mesh_element_1.ai Normal file
View File

File diff suppressed because one or more lines are too long

1805
patch/subroutine/documentation/ElementType/mesh_element_1.pdf Normal file
View File

File diff suppressed because one or more lines are too long

1023
patch/subroutine/documentation/ElementType/mesh_element_2.ai Normal file
View File

File diff suppressed because one or more lines are too long

960
patch/subroutine/documentation/ElementType/mesh_element_2.pdf Normal file
View File

File diff suppressed because one or more lines are too long

2229
patch/subroutine/documentation/ElementType/mesh_element_5.ai Normal file
View File

File diff suppressed because one or more lines are too long

1280
patch/subroutine/documentation/ElementType/mesh_element_5.pdf Normal file
View File

File diff suppressed because one or more lines are too long

4723
patch/subroutine/documentation/ElementType/mesh_element_6.ai Normal file
View File

File diff suppressed because one or more lines are too long

1620
patch/subroutine/documentation/ElementType/mesh_element_6.pdf Normal file
View File

File diff suppressed because one or more lines are too long

713
patch/subroutine/lattice.f90 Normal file
View File

@ -0,0 +1,713 @@
!************************************
!* Module: LATTICE *
!************************************
!* contains: *
!* - Lattice structure definition *
!* - Slip system definition *
!* - Schmid matrices calculation *
!************************************
MODULE lattice
!*** Include other modules ***
use prec, only: pReal,pInt
implicit none
!************************************
!* Lattice structures *
!************************************
integer(pInt) lattice_Nhexagonal, & ! # of hexagonal lattice structure (from tag CoverA_ratio)
lattice_Nstructure ! # of lattice structures (1: fcc,2: bcc,3+: hexagonal)
integer(pInt), parameter :: lattice_maxNslip = 48 ! max # of slip systems over lattice structures
integer(pInt), parameter :: lattice_maxNtwin = 24 ! max # of twin systems over lattice structures
integer(pInt), pointer, dimension(:,:) :: interactionSlipSlip, &
interactionSlipTwin, &
interactionTwinTwin
! Schmid matrices, normal, shear direction and nxd of slip systems
real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Sslip
real(pReal), allocatable, dimension(:,:,:) :: lattice_Sslip_v
real(pReal), allocatable, dimension(:,:,:) :: lattice_sn
real(pReal), allocatable, dimension(:,:,:) :: lattice_sd
real(pReal), allocatable, dimension(:,:,:) :: lattice_st
! Rotation and Schmid matrices, normal, shear direction and nxd of twin systems
real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Qtwin
real(pReal), allocatable, dimension(:,:,:,:) :: lattice_Stwin
real(pReal), allocatable, dimension(:,:,:) :: lattice_Stwin_v
real(pReal), allocatable, dimension(:,:,:) :: lattice_tn
real(pReal), allocatable, dimension(:,:,:) :: lattice_td
real(pReal), allocatable, dimension(:,:,:) :: lattice_tt
real(pReal), allocatable, dimension(:,:) :: lattice_shearTwin
integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipSlip
integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionSlipTwin
integer(pInt), allocatable, dimension(:,:,:) :: lattice_interactionTwinTwin
!============================== fcc (1) =================================
integer(pInt), parameter :: lattice_fcc_Nslip = 12_pInt
integer(pInt), parameter :: lattice_fcc_Ntwin = 12_pInt
integer(pInt) :: lattice_fcc_Nstructure = 0_pInt
real(pReal), dimension(3+3,lattice_fcc_Nslip), parameter :: lattice_fcc_systemSlip = &
reshape((/&
! Slip system <110>{111} Sorted according to Eisenlohr & Hantcherli
0, 1,-1, 1, 1, 1, &
-1, 0, 1, 1, 1, 1, &
1,-1, 0, 1, 1, 1, &
0,-1,-1, -1,-1, 1, &
1, 0, 1, -1,-1, 1, &
-1, 1, 0, -1,-1, 1, &
0,-1, 1, 1,-1,-1, &
-1, 0,-1, 1,-1,-1, &
1, 1, 0, 1,-1,-1, &
0, 1, 1, -1, 1,-1, &
1, 0,-1, -1, 1,-1, &
-1,-1, 0, -1, 1,-1 &
/),(/3+3,lattice_fcc_Nslip/))
real(pReal), dimension(3+3,lattice_fcc_Ntwin), parameter :: lattice_fcc_systemTwin = &
reshape((/&
! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli
-2, 1, 1, 1, 1, 1, &
1,-2, 1, 1, 1, 1, &
1, 1,-2, 1, 1, 1, &
2,-1, 1, -1,-1, 1, &
-1, 2, 1, -1,-1, 1, &
-1,-1,-2, -1,-1, 1, &
-2,-1,-1, 1,-1,-1, &
1, 2,-1, 1,-1,-1, &
1,-1, 2, 1,-1,-1, &
2, 1,-1, -1, 1,-1, &
-1,-2,-1, -1, 1,-1, &
-1, 1, 2, -1, 1,-1 &
/),(/3+3,lattice_fcc_Ntwin/))
real(pReal), dimension(lattice_fcc_Ntwin), parameter :: lattice_fcc_shearTwin = &
reshape((/&
! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812, &
0.7071067812 &
/),(/lattice_fcc_Ntwin/))
integer(pInt), target, dimension(lattice_fcc_Nslip,lattice_fcc_Nslip) :: lattice_fcc_interactionSlipSlip = &
reshape((/&
1,2,2,4,6,5,3,5,5,4,5,6, &
2,1,2,6,4,5,5,4,6,5,3,5, &
2,2,1,5,5,3,5,6,4,6,5,4, &
4,6,5,1,2,2,4,5,6,3,5,5, &
6,4,5,2,1,2,5,3,5,5,4,6, &
5,5,3,2,2,1,6,5,4,5,6,4, &
3,5,5,4,5,6,1,2,2,4,6,5, &
5,4,6,5,3,5,2,1,2,6,4,5, &
5,6,4,6,5,4,2,2,1,5,5,3, &
4,5,6,3,5,5,4,6,5,1,2,2, &
5,3,5,5,4,6,6,4,5,2,1,2, &
6,5,4,5,6,4,5,5,3,2,2,1 &
/),(/lattice_fcc_Nslip,lattice_fcc_Nslip/))
integer(pInt), target, dimension(lattice_fcc_Nslip,lattice_fcc_Ntwin) :: lattice_fcc_interactionSlipTwin = &
reshape((/&
0,0,0,1,1,0,0,1,1,1,0,1, &
0,0,0,1,1,0,0,1,1,1,0,1, &
0,0,0,1,1,0,0,1,1,1,0,1, &
1,1,0,0,0,0,1,0,1,0,1,1, &
1,1,0,0,0,0,1,0,1,0,1,1, &
1,1,0,0,0,0,1,0,1,0,1,1, &
0,1,1,1,0,1,0,0,0,1,1,0, &
0,1,1,1,0,1,0,0,0,1,1,0, &
0,1,1,1,0,1,0,0,0,1,1,0, &
1,0,1,0,1,1,1,1,0,0,0,0, &
1,0,1,0,1,1,1,1,0,0,0,0, &
1,0,1,0,1,1,1,1,0,0,0,0 &
/),(/lattice_fcc_Nslip,lattice_fcc_Ntwin/))
integer(pInt), target, dimension(lattice_fcc_Ntwin,lattice_fcc_Ntwin) :: lattice_fcc_interactionTwinTwin = &
reshape((/&
0,0,0,1,1,1,1,1,1,1,1,1, &
0,0,0,1,1,1,1,1,1,1,1,1, &
0,0,0,1,1,1,1,1,1,1,1,1, &
1,1,1,0,0,0,1,1,1,1,1,1, &
1,1,1,0,0,0,1,1,1,1,1,1, &
1,1,1,0,0,0,1,1,1,1,1,1, &
1,1,1,1,1,1,0,0,0,1,1,1, &
1,1,1,1,1,1,0,0,0,1,1,1, &
1,1,1,1,1,1,0,0,0,1,1,1, &
1,1,1,1,1,1,1,1,1,0,0,0, &
1,1,1,1,1,1,1,1,1,0,0,0, &
1,1,1,1,1,1,1,1,1,0,0,0 &
/),(/lattice_fcc_Ntwin,lattice_fcc_Ntwin/))
!============================== bcc (2) =================================
integer(pInt), parameter :: lattice_bcc_Nslip = 48_pInt
integer(pInt), parameter :: lattice_bcc_Ntwin = 12_pInt
integer(pInt) :: lattice_bcc_Nstructure = 0_pInt
real(pReal), dimension(3+3,lattice_bcc_Nslip), parameter :: lattice_bcc_systemSlip = &
reshape((/&
! Slip system <111>{110} meaningful sorting?
1,-1, 1, 0, 1, 1, &
-1,-1, 1, 0, 1, 1, &
1, 1, 1, 0,-1, 1, &
-1, 1, 1, 0,-1, 1, &
-1, 1, 1, 1, 0, 1, &
-1,-1, 1, 1, 0, 1, &
1, 1, 1, -1, 0, 1, &
1,-1, 1, -1, 0, 1, &
-1, 1, 1, 1, 1, 0, &
-1, 1,-1, 1, 1, 0, &
1, 1, 1, -1, 1, 0, &
1, 1,-1, -1, 1, 0, &
! Slip system <111>{112} meaningful sorting ?
-1, 1, 1, 2, 1, 1, &
1, 1, 1, -2, 1, 1, &
1, 1,-1, 2,-1, 1, &
1,-1, 1, 2, 1,-1, &
1,-1, 1, 1, 2, 1, &
1, 1,-1, -1, 2, 1, &
1, 1, 1, 1,-2, 1, &
-1, 1, 1, 1, 2,-1, &
1, 1,-1, 1, 1, 2, &
1,-1, 1, -1, 1, 2, &
-1, 1, 1, 1,-1, 2, &
1, 1, 1, 1, 1,-2, &
! Slip system <111>{123} meaningful sorting ?
1, 1,-1, 1, 2, 3, &
1,-1, 1, -1, 2, 3, &
-1, 1, 1, 1,-2, 3, &
1, 1, 1, 1, 2,-3, &
1,-1, 1, 1, 3, 2, &
1, 1,-1, -1, 3, 2, &
1, 1, 1, 1,-3, 2, &
-1, 1, 1, 1, 3,-2, &
1, 1,-1, 2, 1, 3, &
1,-1, 1, -2, 1, 3, &
-1, 1, 1, 2,-1, 3, &
1, 1, 1, 2, 1,-3, &
1,-1, 1, 2, 3, 1, &
1, 1,-1, -2, 3, 1, &
1, 1, 1, 2,-3, 1, &
-1, 1, 1, 2, 3,-1, &
-1, 1, 1, 3, 1, 2, &
1, 1, 1, -3, 1, 2, &
1, 1,-1, 3,-1, 2, &
1,-1, 1, 3, 1,-2, &
-1, 1, 1, 3, 2, 1, &
1, 1, 1, -3, 2, 1, &
1, 1,-1, 3,-2, 1, &
1,-1, 1, 3, 2,-1 &
/),(/3+3,lattice_bcc_Nslip/))
! twin system <111>{112}
! MISSING: not implemented yet -- now dummy copy from fcc !!
real(pReal), dimension(3+3,lattice_bcc_Ntwin), parameter :: lattice_bcc_systemTwin = &
reshape((/&
! Twin system <112>{111} Sorted according to Eisenlohr & Hantcherli
-2, 1, 1, 1, 1, 1, &
1,-2, 1, 1, 1, 1, &
1, 1,-2, 1, 1, 1, &
2,-1, 1, -1,-1, 1, &
-1, 2, 1, -1,-1, 1, &
-1,-1,-2, -1,-1, 1, &
-2,-1,-1, 1,-1,-1, &
1, 2,-1, 1,-1,-1, &
1,-1, 2, 1,-1,-1, &
2, 1,-1, -1, 1,-1, &
-1,-2,-1, -1, 1,-1, &
-1, 1, 2, -1, 1,-1 &
/),(/3+3,lattice_bcc_Ntwin/))
real(pReal), dimension(lattice_bcc_Ntwin), parameter :: lattice_bcc_shearTwin = &
reshape((/&
! Twin system {111}<112> just a dummy
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123, &
0.123 &
/),(/lattice_bcc_Ntwin/))
!*** Slip-Slip interactions for BCC structures (2) ***
integer(pInt), target, dimension(lattice_bcc_Nslip,lattice_bcc_Nslip) :: lattice_bcc_interactionSlipSlip = &
reshape((/&
1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 &
/),(/lattice_bcc_Nslip,lattice_bcc_Nslip/))
!*** Slip-twin interactions for BCC structures (2) ***
! MISSING: not implemented yet
integer(pInt), target, dimension(lattice_bcc_Nslip,lattice_bcc_Ntwin) :: lattice_bcc_interactionSlipTwin = &
reshape((/&
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 &
/),(/lattice_bcc_Nslip,lattice_bcc_Ntwin/))
!*** Twin-twin interactions for BCC structures (2) ***
! MISSING: not implemented yet
integer(pInt), target, dimension(lattice_bcc_Ntwin,lattice_bcc_Ntwin) :: lattice_bcc_interactionTwinTwin = &
reshape((/&
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0, &
0,0,0,0,0,0,0,0,0,0,0,0 &
/),(/lattice_bcc_Ntwin,lattice_bcc_Ntwin/))
!============================== hex (3+) =================================
integer(pInt), parameter :: lattice_hex_Nslip = 24_pInt
integer(pInt), parameter :: lattice_hex_Ntwin = 24_pInt
integer(pInt) :: lattice_hex_Nstructure = 0_pInt
real(pReal), dimension(4+4,lattice_hex_Nslip), parameter :: lattice_hex_systemSlip = &
reshape((/&
! Basal systems <1120>{0001} (independent of c/a-ratio, Bravais notation (4 coordinate base))
2, -1, -1, 0, 0, 0, 0, 1, &
-1, 2, -1, 0, 0, 0, 0, 1, &
-1, -1, 2, 0, 0, 0, 0, 1, &
! 1st type prismatic systems <1120>{1010} (independent of c/a-ratio)
2, -1, -1, 0, 0, 1, -1, 0, &
-1, 2, -1, 0, 1, 0, -1, 0, &
-1, -1, 2, 0, -1, 1, 0, 0, &
! 1st type 1st order pyramidal systems <1120>{1011}
2, -1, -1, 0, 0, 1, -1, 1, &
-1, 2, -1, 0, 1, 0, -1, 1, &
-1, -1, 2, 0, -1, 1, 0, 1, &
2, -1, -1, 0, 0, -1, 1, 1, &
-1, 2, -1, 0, -1, 0, 1, 1, &
-1, -1, 2, 0, 1, -1, 0, 1, &
! pyramidal system: c+a slip <2113>{1011} -- plane normals depend on the c/a-ratio
2, -1, -1, -3, 1, 0, -1, 1, &
1, 1, -2, -3, 1, 0, -1, 1, &
1, 1, -2, -3, 0, 1, -1, 1, &
-1, 2, -1, -3, 0, 1, -1, 1, &
-1, 2, -1, -3, -1, 1, 0, 1, &
-2, 1, 1, -3, -1, 1, 0, 1, &
-2, 1, 1, -3, -1, 0, 1, 1, &
-1, -1, 2, -3, -1, 0, 1, 1, &
-1, -1, 2, -3, 0, -1, 1, 1, &
1, -2, 1, -3, 0, -1, 1, 1, &
1, -2, 1, -3, 1, -1, 0, 1, &
2, -1, -1, -3, 1, -1, 0, 1 &
/),(/4+4,lattice_hex_Nslip/))
real(pReal), dimension(4+4,lattice_hex_Ntwin), parameter :: lattice_hex_systemTwin = &
reshape((/&
-1, 0, 1, 1, 1, 0, -1, 2, & ! <1011>{1012} Twin: shear 0.169 -1.26 compression
0, -1, 1, 1, 0, 1, -1, 2, &
1, -1, 0, 1, -1, 1, 0, 2, &
1, 0, -1, 1, -1, 0, 1, 2, &
0, 1, -1, 1, 0, -1, 1, 2, &
-1, 1, 0, 1, 1, -1, 0, 2, &
2, -1, -1, -3, 2, -1, -1, 2, & ! <211-2>{2112} Twin: shear 0.224 1.19 tension
1, 1, -2, -3, 1, 1, -2, 2, &
-1, 2, -1, -3, -1, 2, -1, 2, &
-2, 1, 1, -3, -2, 1, 1, 2, &
-1, -1, 2, -3, -1, -1, 2, 2, &
1, -2, 1, -3, 1, -2, 1, 2, &
-2, 1, 1, 6, 2, -1, -1, 1, & ! <211-6>{2111} Twin: shear 0.628 -0.39 compression
-1, -1, 2, 6, 1, 1, -2, 1, &
1, -2, 1, 6, -1, 2, -1, 1, &
2, -1, -1, 6, -2, 1, 1, 1, &
1, 1, -2, 6, -1, -1, 2, 1, &
-1, 2, -1, 6, 1, -2, 1, 1, &
1, 0, -1, -2, 1, 0, -1, 1, & ! <101-2>{1011} Twin: shear 0.103 1.09 tension
-1, 0, 1, -2, -1, 0, 1, 1, &
0, 1, -1, -2, 0, 1, -1, 1, &
0, -1, 1, -2, 0, -1, 1, 1, &
1, -1, 0, -2, 1, -1, 0, 1, &
-1, 1, 0, -2, -1, 1, 0, 1 &
/),(/4+4,lattice_hex_Ntwin/)) !* Sort? Numbering of twin system follows Prof. Tom Bieler's scheme (to be consistent with his work); but numbering in data was restarted from 1 &
real(pReal), dimension(lattice_hex_Ntwin), parameter :: lattice_hex_shearTwin = &
reshape((/&
0.169, & ! <1011>{1012} Twin: shear 0.169 -1.26 compression
0.169, &
0.169, &
0.169, &
0.169, &
0.169, &
0.224, & ! <211-2>{2112} Twin: shear 0.224 1.19 tension
0.224, &
0.224, &
0.224, &
0.224, &
0.224, &
0.628, & ! <211-6>{2111} Twin: shear 0.628 -0.39 compression
0.628, &
0.628, &
0.628, &
0.628, &
0.628, &
0.103, & ! <101-2>{1011} Twin: shear 0.103 1.09 tension
0.103, &
0.103, &
0.103, &
0.103, &
0.103 &
/),(/lattice_hex_Ntwin/))
integer(pInt), target, dimension(lattice_hex_Nslip,lattice_hex_Nslip) :: lattice_hex_interactionSlipSlip = &
reshape((/&
1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 &
/),(/lattice_hex_Nslip,lattice_hex_Nslip/))
integer(pInt), target, dimension(lattice_hex_Nslip,lattice_hex_Ntwin) :: lattice_hex_interactionSlipTwin = &
reshape((/&
1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 &
/),(/lattice_hex_Nslip,lattice_hex_Ntwin/))
integer(pInt), target, dimension(lattice_hex_Ntwin,lattice_hex_Ntwin) :: lattice_hex_interactionTwinTwin = &
reshape((/&
1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2, &
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 &
/),(/lattice_hex_Ntwin,lattice_hex_Ntwin/))
CONTAINS
!****************************************
!* - lattice_init
!* - lattice_initializeStructure
!****************************************
subroutine lattice_init()
!**************************************
!* Module initialization *
!**************************************
use IO, only: IO_open_file,IO_countSections,IO_countTagInPart,IO_error
use material, only: material_configfile,material_partPhase
implicit none
integer(pInt), parameter :: fileunit = 200
integer(pInt) i,Nsections
if(.not. IO_open_file(fileunit,material_configFile)) call IO_error (100) ! corrupt config file
Nsections = IO_countSections(fileunit,material_partPhase)
lattice_Nstructure = 2_pInt + sum(IO_countTagInPart(fileunit,material_partPhase,'covera_ratio',Nsections)) ! fcc + bcc + all hex
close(fileunit)
allocate(lattice_Sslip(3,3,lattice_maxNslip,lattice_Nstructure)); lattice_Sslip = 0.0_pReal
allocate(lattice_Sslip_v(6,lattice_maxNslip,lattice_Nstructure)); lattice_Sslip_v = 0.0_pReal
allocate(lattice_sd(3,lattice_maxNslip,lattice_Nstructure)); lattice_sd = 0.0_pReal
allocate(lattice_st(3,lattice_maxNslip,lattice_Nstructure)); lattice_st = 0.0_pReal
allocate(lattice_sn(3,lattice_maxNslip,lattice_Nstructure)); lattice_sn = 0.0_pReal
allocate(lattice_Qtwin(3,3,lattice_maxNtwin,lattice_Nstructure)); lattice_Qtwin = 0.0_pReal
allocate(lattice_Stwin(3,3,lattice_maxNtwin,lattice_Nstructure)); lattice_Stwin = 0.0_pReal
allocate(lattice_Stwin_v(6,lattice_maxNtwin,lattice_Nstructure)); lattice_Stwin_v = 0.0_pReal
allocate(lattice_td(3,lattice_maxNtwin,lattice_Nstructure)); lattice_td = 0.0_pReal
allocate(lattice_tt(3,lattice_maxNtwin,lattice_Nstructure)); lattice_tt = 0.0_pReal
allocate(lattice_tn(3,lattice_maxNtwin,lattice_Nstructure)); lattice_tn = 0.0_pReal
allocate(lattice_shearTwin(lattice_maxNtwin,lattice_Nstructure)); lattice_shearTwin = 0.0_pReal
allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,lattice_Nstructure)); lattice_interactionSlipSlip = 0_pInt
allocate(lattice_interactionSlipTwin(lattice_maxNslip,lattice_maxNtwin,lattice_Nstructure)); lattice_interactionSlipTwin = 0_pInt
allocate(lattice_interactionTwinTwin(lattice_maxNtwin,lattice_maxNtwin,lattice_Nstructure)); lattice_interactionTwinTwin = 0_pInt
write(6,*) 'lattice Nstructure',lattice_Nstructure
end subroutine
function lattice_initializeStructure(struct,CoverA)
!**************************************
!* Calculation of Schmid *
!* matrices, etc. *
!**************************************
use prec, only: pReal,pInt
use math
implicit none
character(len=*) struct
real(pReal) CoverA
real(pReal), dimension(3,lattice_maxNslip) :: sd = 0.0_pReal, &
sn = 0.0_pReal, &
st = 0.0_pReal
real(pReal), dimension(3,lattice_maxNtwin) :: td = 0.0_pReal, &
tn = 0.0_pReal, &
tt = 0.0_pReal
real(pReal), dimension(lattice_maxNtwin) :: ts = 0.0_pReal
real(pReal), dimension(3) :: hex_d = 0.0_pReal, &
hex_n = 0.0_pReal
integer(pInt) :: i,myNslip,myNtwin,myStructure = 0_pInt
logical :: processMe = .false.
integer(pInt) lattice_initializeStructure
write(6,*) 'initialize structure', struct
select case(struct(1:3)) ! check first three chars of structure name
case ('fcc')
myStructure = 1_pInt
myNslip = lattice_fcc_Nslip
myNtwin = lattice_fcc_Ntwin
lattice_fcc_Nstructure = lattice_fcc_Nstructure + 1_pInt
if (lattice_fcc_Nstructure == 1_pInt) then
processMe = .true.
do i = 1,myNslip
sn(:,i) = lattice_fcc_systemSlip(1:3,i)/dsqrt(math_mul3x3(lattice_fcc_systemSlip(1:3,i),lattice_fcc_systemSlip(1:3,i)))
sd(:,i) = lattice_fcc_systemSlip(4:6,i)/dsqrt(math_mul3x3(lattice_fcc_systemSlip(4:6,i),lattice_fcc_systemSlip(4:6,i)))
st(:,i) = math_vectorproduct(sn(:,i),sd(:,i))
enddo
do i = 1,myNtwin
tn(:,i) = lattice_fcc_systemTwin(1:3,i)/dsqrt(math_mul3x3(lattice_fcc_systemTwin(1:3,i),lattice_fcc_systemTwin(1:3,i)))
td(:,i) = lattice_fcc_systemTwin(4:6,i)/dsqrt(math_mul3x3(lattice_fcc_systemTwin(4:6,i),lattice_fcc_systemTwin(4:6,i)))
tt(:,i) = math_vectorproduct(tn(:,i),td(:,i))
ts(i) = lattice_fcc_shearTwin(i)
enddo
interactionSlipSlip => lattice_fcc_interactionSlipSlip
interactionSlipTwin => lattice_fcc_interactionSlipTwin
interactionTwinTwin => lattice_fcc_interactionTwinTwin
endif
case ('bcc')
myStructure = 2_pInt
myNslip = lattice_bcc_Nslip
myNtwin = lattice_bcc_Ntwin
lattice_bcc_Nstructure = lattice_bcc_Nstructure + 1_pInt
if (lattice_bcc_Nstructure == 1_pInt) then
processMe = .true.
do i = 1,myNslip
sn(:,i) = lattice_bcc_systemSlip(1:3,i)/dsqrt(math_mul3x3(lattice_bcc_systemSlip(1:3,i),lattice_bcc_systemSlip(1:3,i)))
sd(:,i) = lattice_bcc_systemSlip(4:6,i)/dsqrt(math_mul3x3(lattice_bcc_systemSlip(4:6,i),lattice_bcc_systemSlip(4:6,i)))
st(:,i) = math_vectorproduct(sn(:,i),sd(:,i))
enddo
do i = 1,myNtwin
tn(:,i) = lattice_bcc_systemTwin(1:3,i)/dsqrt(math_mul3x3(lattice_bcc_systemTwin(1:3,i),lattice_bcc_systemTwin(1:3,i)))
td(:,i) = lattice_bcc_systemTwin(4:6,i)/dsqrt(math_mul3x3(lattice_bcc_systemTwin(4:6,i),lattice_bcc_systemTwin(4:6,i)))
tt(:,i) = math_vectorproduct(tn(:,i),td(:,i))
ts(i) = lattice_bcc_shearTwin(i)
enddo
interactionSlipSlip => lattice_bcc_interactionSlipSlip
interactionSlipTwin => lattice_bcc_interactionSlipTwin
interactionTwinTwin => lattice_bcc_interactionTwinTwin
endif
case ('hex')
if (CoverA > 0.0_pReal) then
lattice_hex_Nstructure = lattice_hex_Nstructure + 1_pInt
myStructure = 2_pInt + lattice_hex_Nstructure
myNslip = lattice_hex_Nslip
myNtwin = lattice_hex_Ntwin
processMe = .true.
! converting from 4 axes coordinate system (a1=a2=a3=c) to ortho-hexgonal system (a, b, c)
do i = 1,myNslip
hex_n(1) = lattice_hex_systemSlip(1,i) ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a))
hex_n(2) = (lattice_hex_systemSlip(1,i)+2.0_pReal*lattice_hex_systemSlip(2,i))/dsqrt(3.0_pReal)
hex_n(3) = lattice_hex_systemSlip(4,i)/CoverA
hex_d(1) = lattice_hex_systemSlip(5,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]
hex_d(2) = (lattice_hex_systemSlip(5,i)+2.0_pReal*lattice_hex_systemSlip(6,i))*(0.5_pReal*dsqrt(3.0_pReal))
hex_d(3) = lattice_hex_systemSlip(8,i)*CoverA
sn(:,i) = hex_n/dsqrt(math_mul3x3(hex_n,hex_n))
sd(:,i) = hex_d/dsqrt(math_mul3x3(hex_d,hex_d))
st(:,i) = math_vectorproduct(sn(:,i),sd(:,i))
enddo
do i = 1,myNtwin
hex_n(1) = lattice_hex_systemTwin(1,i)
hex_n(2) = (lattice_hex_systemTwin(1,i)+2.0_pReal*lattice_hex_systemTwin(2,i))/dsqrt(3.0_pReal)
hex_n(3) = lattice_hex_systemTwin(4,i)/CoverA
hex_d(1) = lattice_hex_systemTwin(5,i)*1.5_pReal
hex_d(2) = (lattice_hex_systemTwin(5,i)+2.0_pReal*lattice_hex_systemTwin(6,i))*(0.5_pReal*dsqrt(3.0_pReal))
hex_d(3) = lattice_hex_systemTwin(8,i)*CoverA
tn(:,i) = hex_n/dsqrt(math_mul3x3(hex_n,hex_n))
td(:,i) = hex_d/dsqrt(math_mul3x3(hex_d,hex_d))
tt(:,i) = math_vectorproduct(tn(:,i),td(:,i))
ts(i) = lattice_hex_shearTwin(i)
enddo
interactionSlipSlip => lattice_hex_interactionSlipSlip
interactionSlipTwin => lattice_hex_interactionSlipTwin
interactionTwinTwin => lattice_hex_interactionTwinTwin
endif
end select
if (processMe) then
do i = 1,myNslip
lattice_sd(:,i,myStructure) = sd(:,i)
lattice_st(:,i,myStructure) = st(:,i)
lattice_sn(:,i,myStructure) = sn(:,i)
lattice_Sslip(:,:,i,myStructure) = math_tensorproduct(sd(:,i),sn(:,i))
lattice_Sslip_v(:,i,myStructure) = math_Mandel33to6(math_symmetric3x3(lattice_Sslip(:,:,i,myStructure)))
enddo
do i = 1,myNtwin
lattice_td(:,i,myStructure) = td(:,i)
lattice_tt(:,i,myStructure) = tt(:,i)
lattice_tn(:,i,myStructure) = tn(:,i)
lattice_Stwin(:,:,i,myStructure) = math_tensorproduct(td(:,i),tn(:,i))
lattice_Stwin_v(:,i,myStructure) = math_Mandel33to6(math_symmetric3x3(lattice_Stwin(:,:,i,myStructure)))
lattice_Qtwin(:,:,i,myStructure) = math_RodrigToR(tn(:,i),180.0_pReal*inRad)
lattice_shearTwin(i,myStructure) = ts(i)
enddo
lattice_interactionSlipSlip(1:myNslip,1:myNslip,myStructure) = interactionSlipSlip(1:myNslip,1:myNslip)
lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myStructure) = interactionSlipTwin(1:myNslip,1:myNtwin)
lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myStructure) = interactionTwinTwin(1:myNtwin,1:myNtwin)
endif
lattice_initializeStructure = myStructure
write(6,*) 'lattice_initializeStructure', myStructure
end function
END MODULE

26
patch/subroutine/makeMe.py Normal file
View File

@ -0,0 +1,26 @@
#!/usr/bin/env python
import os,sys
architectures = {
'marc': {
'parent': 'mpie_cpfem_marc.f90',
'versions' : ['%%MARCVERSION%%','2007r1','2008r1'],
},
}
for arch in architectures:
try:
parent = architectures[arch]['parent']
parentFile = open(parent)
parentContent = parentFile.readlines()
parentFile.close()
except IOError:
print 'unable to open',parent
continue
for version in architectures[arch]['versions'][1:]:
childFile = open(os.path.splitext(parent)[0]+version+os.path.splitext(parent)[1],'w')
for line in parentContent:
childFile.write(line.replace(architectures[arch]['versions'][0],version))
childFile.close()

147
patch/subroutine/material.config Normal file
View File

@ -0,0 +1,147 @@
#####################
<homogenization>
#####################
[SX]
type Taylor
Ngrains 1
[RGC]
type RGC
Ngrains 8
[Taylor4]
type Taylor
Ngrains 4
#####################
<microstructure>
#####################
[Aluminum_CubeSX]
(constituent) phase 1 texture 2 fraction 1.0
[Copper_rCubeSX]
(constituent) phase 2 texture 3 fraction 1.0
[DPsteel]
(constituent) phase 3 texture 1 fraction 0.8
(constituent) phase 4 texture 1 fraction 0.2
#####################
<phase>
#####################
[Aluminum] # below given format will not work. need to select one constitution block from it.
constitution j2
c11 110.9e9
c12 58.34e9
(output) flowstress
(output) strainrate
taylorfactor 3
s0 31e6
gdot0 0.001
n 20
h0 75e6
s_sat 63e6
w0 2.25
constitution phenomenological
lattice_structure fcc
Nslip 12
c11 106.75e9
c12 60.41e9
c44 28.34e9
(output) slipresistance
(output) rateofshear
s0_slip 31e6
gdot0_slip 0.001
n_slip 20
h0 75e6
s_sat 63e6
w0 2.25
latent_ratio 1.4
constitution dislobased
(output) dislodensity
(output) rateofshear
burgers 2.86e-10 # Burgers vector [m]
Qedge 3e-19 # Activation energy for dislocation glide [J/K] (0.5*G*b^3)
Qsd 2.4e-19 # Activation energy for self diffusion [J/K] (gamma-iron)
diff0 1e-3 # prefactor vacancy diffusion coeffficent (gamma-iron)
interaction_coefficients 1.0 2.2 3.0 1.6 3.8 4.5 # Dislocation interaction coefficients
rho0 6.0e12 # Initial dislocation density [m/m^3]
c1 0.1 # Passing stress adjustment
c2 2.0 # Jump width adjustment
c3 1.0 # Activation volume adjustment
c4 50.0 # Average slip distance adjustment for lock formation
c7 8.0 # Athermal recovery adjustment
c8 1.0e10 # Thermal recovery adjustment (plays no role for me)
[Copper]
[Ferrite]
[Martensite]
[TWIP steel FeMnC]
constitution phenomenological
lattice_structure fcc
Nslip 12
(output) slipResistance
(output) rateOfShear
C11 183.9e9 # elastic constants in Pa
C12 101.9e9
C44 115.4e9
### phenomenological constitutive parameters ###
s0_slip 85.0e6 # initial slip resistance
gdot0_slip 0.001 # reference shear rate
n_slip 100.0 # stress exponent
h0 355.0e6 # initial hardening slope
s_sat 265.0e6 # saturation stress
w0 1.0 # exponent
latent_ratio 1.4 # latent/self hardening ratio
### dislocation density-based constitutive parameters ###
burgers 2.56e-10 # Burgers vector [m]
Qedge 5.5e-19 # Activation energy for dislocation glide [J/K] (0.5*G*b^3)
Qsd 4.7e-19 # Activation energy for self diffusion [J/K] (gamma-iron)
diff0 4.0e-5 # prefactor vacancy diffusion coeffficent (gamma-iron)
grain_size 2.0e-5 # Average grain size [m]
interaction_coefficients 1.0 2.2 3.0 1.6 3.8 4.5 # Dislocation interaction coefficients
rho0 6.0e12 # Initial dislocation density [m/m^3]
c1 0.1 # Passing stress adjustment
c2 2.0 # Jump width adjustment
c3 1.0 # Activation volume adjustment
c4 50.0 # Average slip distance adjustment for lock formation
c5 1.0 # Average slip distance adjustment when grain boundaries
c7 8.0 # Athermal recovery adjustment
c8 1.0e10 # Thermal recovery adjustment (plays no role for me)
stack_size 5.0e-8 # Average twin thickness (stacks) [m]
f_sat 1.0 # Total twin volume fraction saturation
c6 # Average slip distance adjustment when twin boundaries [???]
site_scaling 1.0e-6 # Scaling potential nucleation sites
q1 1.0 # Scaling the P-K force on the twinning dislocation
q2 1.0 # Scaling the resolved shear stress
#####################
<texture>
#####################
[random]
[CubeSX]
(gauss) phi1 0.0 Phi 0.0 phi2 0.0 scatter 0.0 fraction 1.0
[rCubeSX]
(gauss) phi1 45.0 Phi 0.0 phi2 0.0 scatter 0.0 fraction 1.0

631
patch/subroutine/material.f90 Normal file
View File

@ -0,0 +1,631 @@
!************************************
!* Module: MATERIAL *
!************************************
!* contains: *
!* - parsing of material.config *
!************************************
MODULE material
!*** Include other modules ***
use prec, only: pReal,pInt
implicit none
character(len=64), parameter :: material_configFile = 'material.config'
character(len=32), parameter :: material_partHomogenization = 'homogenization'
character(len=32), parameter :: material_partMicrostructure = 'microstructure'
character(len=32), parameter :: material_partPhase = 'phase'
character(len=32), parameter :: material_partTexture = 'texture'
!*************************************
!* Definition of material properties *
!*************************************
!* Number of materials
integer(pInt) material_Nhomogenization, & ! number of homogenizations
material_Nmicrostructure, & ! number of microstructures
material_Nphase, & ! number of phases
material_Ntexture, & ! number of textures
microstructure_maxNconstituents, & ! max number of constituents in any phase
homogenization_maxNgrains, & ! max number of grains in any homogenization
texture_maxNgauss, & ! max number of Gauss components in any texture
texture_maxNfiber ! max number of Fiber components in any texture
character(len=64), dimension(:), allocatable :: homogenization_name, & ! name of each homogenization
homogenization_type, & ! type of each homogenization
microstructure_name, & ! name of each microstructure
phase_name, & ! name of each phase
phase_constitution, & ! constitution of each phase
texture_name ! name of each texture
character(len=256),dimension(:), allocatable :: texture_ODFfile ! name of each ODF file
integer(pInt), dimension(:), allocatable :: homogenization_Ngrains, & ! number of grains in each homogenization
homogenization_typeInstance, & ! instance of particular type of each homogenization
homogenization_Noutput, & ! number of '(output)' items per homogenization
microstructure_Nconstituents, & ! number of constituents in each microstructure
phase_constitutionInstance, & ! instance of particular constitution of each phase
phase_Noutput, & ! number of '(output)' items per phase
phase_localConstitution, & ! flag phases with local constitutive law
texture_symmetry, & ! number of symmetric orientations per texture
texture_Ngauss, & ! number of Gauss components per texture
texture_Nfiber ! number of Fiber components per texture
integer(pInt), dimension(:,:), allocatable :: microstructure_phase, & ! phase IDs of each microstructure
microstructure_texture ! texture IDs of each microstructure
real(pReal), dimension(:,:), allocatable :: microstructure_fraction ! vol fraction of each constituent in microstructure
real(pReal), dimension(:,:,:), allocatable :: material_volFrac ! vol fraction of grain within phase (?)
integer(pInt), dimension(:,:,:), allocatable :: material_phase ! phase of each grain,IP,element
real(pReal), dimension(:,:,:,:), allocatable :: material_EulerAngles ! initial orientation of each grain,IP,element
real(pReal), dimension(:,:,:), allocatable :: texture_Gauss, & ! data of each Gauss component
texture_Fiber ! data of each Fiber component
CONTAINS
!*********************************************************************
subroutine material_init()
!*********************************************************************
!* Module initialization *
!**************************************
use prec, only: pReal,pInt
use IO, only: IO_error, IO_open_file
implicit none
!* Definition of variables
integer(pInt), parameter :: fileunit = 200
integer(pInt) i
if(.not. IO_open_file(fileunit,material_configFile)) call IO_error (100) ! corrupt config file
write(6,*) 'parsing homogenization...'
call material_parseHomogenization(fileunit,material_partHomogenization)
write(6,*) 'parsing microstrcuture...'
call material_parseMicrostructure(fileunit,material_partMicrostructure)
write(6,*) 'parsing texture...'
call material_parseTexture(fileunit,material_partTexture)
write(6,*) 'parsing phase...'
call material_parsePhase(fileunit,material_partPhase)
close(fileunit)
do i = 1,material_Nmicrostructure
if (minval(microstructure_phase(1:microstructure_Nconstituents(i),i)) < 1 .or. &
maxval(microstructure_phase(1:microstructure_Nconstituents(i),i)) > material_Nphase) call IO_error(150,i)
if (minval(microstructure_texture(1:microstructure_Nconstituents(i),i)) < 1 .or. &
maxval(microstructure_texture(1:microstructure_Nconstituents(i),i)) > material_Ntexture) call IO_error(160,i)
if (sum(microstructure_fraction(:,i)) /= 1.0_pReal) call IO_error(170,i)
enddo
write (6,*)
write (6,*) 'MATERIAL configuration'
write (6,*)
write (6,*) 'Homogenization'
do i = 1,material_Nhomogenization
write (6,'(a32,x,a16,x,i4)') homogenization_name(i),homogenization_type(i),homogenization_Ngrains(i)
enddo
write (6,*)
write (6,*) 'Microstructure'
do i = 1,material_Nmicrostructure
write (6,'(a32,x,i4)') microstructure_name(i),microstructure_Nconstituents(i)
enddo
write(6,*) 'populating grains...'
call material_populateGrains()
write(6,*) 'populating grains finished...'
end subroutine
!*********************************************************************
subroutine material_parseHomogenization(file,myPart)
!*********************************************************************
use prec, only: pInt
use IO
implicit none
character(len=*), intent(in) :: myPart
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 2
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) Nsections, section, s
character(len=64) tag
character(len=1024) line
Nsections= IO_countSections(file,myPart)
material_Nhomogenization = Nsections
allocate(homogenization_name(Nsections)); homogenization_name = ''
allocate(homogenization_type(Nsections)); homogenization_type = ''
allocate(homogenization_typeInstance(Nsections)); homogenization_typeInstance = 0_pInt
allocate(homogenization_Ngrains(Nsections)); homogenization_Ngrains = 0_pInt
homogenization_Noutput = IO_countTagInPart(file,myPart,'(output)',Nsections)
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to myPart
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
homogenization_name(section) = IO_getTag(line,'[',']')
endif
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('type')
homogenization_type(section) = IO_stringValue(line,positions,2)
do s = 1,section
if (homogenization_type(s) == homogenization_type(section)) &
homogenization_typeInstance(section) = homogenization_typeInstance(section) + 1 ! count instances
enddo
case ('ngrains')
homogenization_Ngrains(section) = IO_intValue(line,positions,2)
end select
endif
enddo
100 homogenization_maxNgrains = maxval(homogenization_Ngrains)
return
end subroutine
!*********************************************************************
subroutine material_parseMicrostructure(file,myPart)
!*********************************************************************
use prec, only: pInt
use IO
implicit none
character(len=*), intent(in) :: myPart
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 7
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) Nsections, section, constituent, i
character(len=64) tag
character(len=1024) line
Nsections = IO_countSections(file,myPart)
material_Nmicrostructure = Nsections
allocate(microstructure_name(Nsections)); microstructure_name = ''
allocate(microstructure_Nconstituents(Nsections))
microstructure_Nconstituents = IO_countTagInPart(file,myPart,'(constituent)',Nsections)
microstructure_maxNconstituents = maxval(microstructure_Nconstituents)
allocate(microstructure_phase (microstructure_maxNconstituents,Nsections)); microstructure_phase = 0_pInt
allocate(microstructure_texture (microstructure_maxNconstituents,Nsections)); microstructure_texture = 0_pInt
allocate(microstructure_fraction(microstructure_maxNconstituents,Nsections)); microstructure_fraction = 0.0_pReal
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to myPart
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
constituent = 0
microstructure_name(section) = IO_getTag(line,'[',']')
endif
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('(constituent)')
constituent = constituent + 1
do i=2,6,2
tag = IO_lc(IO_stringValue(line,positions,i))
select case (tag)
case('phase')
microstructure_phase(constituent,section) = IO_intValue(line,positions,i+1)
case('texture')
microstructure_texture(constituent,section) = IO_intValue(line,positions,i+1)
case('fraction')
microstructure_fraction(constituent,section) = IO_floatValue(line,positions,i+1)
end select
enddo
end select
endif
enddo
100 return
end subroutine
!*********************************************************************
subroutine material_parsePhase(file,myPart)
!*********************************************************************
use prec, only: pInt
use IO
implicit none
character(len=*), intent(in) :: myPart
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 2
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) Nsections, section, s
character(len=64) tag
character(len=1024) line
Nsections = IO_countSections(file,myPart)
material_Nphase = Nsections
allocate(phase_name(Nsections)); phase_name = ''
allocate(phase_constitution(Nsections)); phase_constitution = ''
allocate(phase_constitutionInstance(Nsections)); phase_constitutionInstance = 0_pInt
allocate(phase_Noutput(Nsections))
allocate(phase_localConstitution(Nsections))
phase_Noutput = IO_countTagInPart(file,myPart,'(output)',Nsections)
phase_localConstitution = .not. IO_spotTagInPart(file,myPart,'/nonlocal/',Nsections)
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to myPart
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
phase_name(section) = IO_getTag(line,'[',']')
endif
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('constitution')
phase_constitution(section) = IO_lc(IO_stringValue(line,positions,2))
do s = 1,section
if (phase_constitution(s) == phase_constitution(section)) &
phase_constitutionInstance(section) = phase_constitutionInstance(section) + 1 ! count instances
enddo
end select
endif
enddo
100 return
end subroutine
!*********************************************************************
subroutine material_parseTexture(file,myPart)
!*********************************************************************
use prec, only: pInt, pReal
use IO
use math, only: inRad
implicit none
character(len=*), intent(in) :: myPart
integer(pInt), intent(in) :: file
integer(pInt), parameter :: maxNchunks = 13
integer(pInt), dimension(1+2*maxNchunks) :: positions
integer(pInt) Nsections, section, gauss, fiber, i
character(len=64) tag
character(len=1024) line
Nsections = IO_countSections(file,myPart)
material_Ntexture = Nsections
allocate(texture_name(Nsections)); texture_name = ''
allocate(texture_ODFfile(Nsections)); texture_ODFfile = ''
allocate(texture_symmetry(Nsections)); texture_symmetry = 1_pInt
allocate(texture_Ngauss(Nsections)); texture_Ngauss = 0_pInt
allocate(texture_Nfiber(Nsections)); texture_Nfiber = 0_pInt
texture_Ngauss = IO_countTagInPart(file,myPart,'(gauss)',Nsections)
texture_Nfiber = IO_countTagInPart(file,myPart,'(fiber)',Nsections)
texture_maxNgauss = maxval(texture_Ngauss)
texture_maxNfiber = maxval(texture_Nfiber)
allocate(texture_Gauss (5,texture_maxNgauss,Nsections)); texture_Gauss = 0.0_pReal
allocate(texture_Fiber (6,texture_maxNfiber,Nsections)); texture_Fiber = 0.0_pReal
rewind(file)
line = ''
section = 0
do while (IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to myPart
read(file,'(a1024)',END=100) line
enddo
do
read(file,'(a1024)',END=100) line
if (IO_isBlank(line)) cycle ! skip empty lines
if (IO_getTag(line,'<','>') /= '') exit ! stop at next part
if (IO_getTag(line,'[',']') /= '') then ! next section
section = section + 1
gauss = 0
fiber = 0
texture_name(section) = IO_getTag(line,'[',']')
endif
if (section > 0) then
positions = IO_stringPos(line,maxNchunks)
tag = IO_lc(IO_stringValue(line,positions,1)) ! extract key
select case(tag)
case ('hybridia')
texture_ODFfile(section) = IO_stringValue(line,positions,2)
case ('symmetry')
tag = IO_lc(IO_stringValue(line,positions,2))
select case (tag)
case('orthotropic')
texture_symmetry(section) = 4
case('monoclinic')
texture_symmetry(section) = 2
case default
texture_symmetry(section) = 1
end select
case ('(gauss)')
gauss = gauss + 1
do i = 2,10,2
tag = IO_lc(IO_stringValue(line,positions,i))
select case (tag)
case('phi1')
texture_Gauss(1,gauss,section) = IO_floatValue(line,positions,i+1)*inRad
case('phi')
texture_Gauss(2,gauss,section) = IO_floatValue(line,positions,i+1)*inRad
case('phi2')
texture_Gauss(3,gauss,section) = IO_floatValue(line,positions,i+1)*inRad
case('scatter')
texture_Gauss(4,gauss,section) = IO_floatValue(line,positions,i+1)*inRad
case('fraction')
texture_Gauss(5,gauss,section) = IO_floatValue(line,positions,i+1)
end select
enddo
case ('(fiber)')
fiber = fiber + 1
do i = 2,12,2
tag = IO_lc(IO_stringValue(line,positions,i))
select case (tag)
case('aplha1')
texture_Fiber(1,fiber,section) = IO_floatValue(line,positions,i+1)*inRad
case('alpha2')
texture_Fiber(2,fiber,section) = IO_floatValue(line,positions,i+1)*inRad
case('beta1')
texture_Fiber(3,fiber,section) = IO_floatValue(line,positions,i+1)*inRad
case('beta2')
texture_Fiber(4,fiber,section) = IO_floatValue(line,positions,i+1)*inRad
case('scatter')
texture_Fiber(5,fiber,section) = IO_floatValue(line,positions,i+1)*inRad
case('fraction')
texture_Fiber(6,fiber,section) = IO_floatValue(line,positions,i+1)
end select
enddo
end select
endif
enddo
100 return
end subroutine
!*********************************************************************
subroutine material_populateGrains()
!*********************************************************************
use prec, only: pInt, pReal
use math, only: math_sampleRandomOri, math_sampleGaussOri, math_sampleFiberOri, math_symmetricEulers
use mesh, only: mesh_element, mesh_maxNips, mesh_NcpElems, mesh_ipVolume, FE_Nips
use IO, only: IO_error, IO_hybridIA
implicit none
integer(pInt), dimension (:,:), allocatable :: Ngrains
integer(pInt), dimension (microstructure_maxNconstituents) :: NgrainsOfConstituent
real(pReal), dimension (:), allocatable :: volFracOfGrain, phaseOfGrain
real(pReal), dimension (:,:), allocatable :: orientationOfGrain
real(pReal), dimension (3) :: orientation
real(pReal), dimension (3,3) :: symOrientation
integer(pInt) t,e,i,g,j,m,homog,micro,sgn
integer(pInt) phaseID,textureID,dGrains,myNgrains,myNorientations, &
grain,constituentGrain,symExtension
real(pReal) extreme,rnd
allocate(material_volFrac(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_volFrac = 0.0_pReal
allocate(material_phase(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_phase = 0_pInt
allocate(material_EulerAngles(3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; material_EulerAngles = 0.0_pReal
allocate(Ngrains(material_Nhomogenization,material_Nmicrostructure)); Ngrains = 0_pInt
! count grains per homog/micro pair
do e = 1,mesh_NcpElems
homog = mesh_element(3,e)
micro = mesh_element(4,e)
if (homog < 1 .or. homog > material_Nhomogenization) & ! out of bounds
call IO_error(130,e,0,0)
if (micro < 1 .or. micro > material_Nmicrostructure) & ! out of bounds
call IO_error(140,e,0,0)
Ngrains(homog,micro) = Ngrains(homog,micro) + homogenization_Ngrains(homog) * FE_Nips(mesh_element(2,e))
enddo
allocate(volFracOfGrain(maxval(Ngrains))) ! reserve memory for maximum case
allocate(phaseOfGrain(maxval(Ngrains))) ! reserve memory for maximum case
allocate(orientationOfGrain(3,maxval(Ngrains))) ! reserve memory for maximum case
write (6,*)
write (6,*) 'MATERIAL grain population'
do homog = 1,material_Nhomogenization ! loop over homogenizations
dGrains = homogenization_Ngrains(homog) ! grain number per material point
do micro = 1,material_Nmicrostructure ! all pairs of homog and micro
if (Ngrains(homog,micro) > 0) then ! an active pair of homog and micro
myNgrains = Ngrains(homog,micro) ! assign short name
write (6,*)
write (6,'(a32,x,a32,x,i6)') homogenization_name(homog),microstructure_name(micro),myNgrains
! ----------------------------------------------------------------------------
volFracOfGrain = 0.0_pReal
grain = 0_pInt ! microstructure grain index
do e = 1,mesh_NcpElems ! check each element
if (mesh_element(3,e) == homog .and. mesh_element(4,e) == micro) then ! my combination of homog and micro
forall (i = 1:FE_Nips(mesh_element(2,e))) & ! loop over IPs
volFracOfGrain(grain+(i-1)*dGrains+1:grain+i*dGrains) = mesh_ipVolume(i,e)/dGrains ! assign IPvolfrac/Ngrains to grains
grain = grain + FE_Nips(mesh_element(2,e)) * dGrains ! wind forward by Nips*NgrainsPerIP
endif
enddo
write (6,*) 'now at grain count',grain
! ----------------------------------------------------------------------------
NgrainsOfConstituent = 0_pInt
forall (i = 1:microstructure_Nconstituents(micro)) &
NgrainsOfConstituent(i) = nint(microstructure_fraction(i,micro) * myNgrains, pInt)
write (6,*) 'NgrainsOfConstituent',NgrainsOfConstituent
do while (sum(NgrainsOfConstituent) /= myNgrains) ! total grain count over constituents wrong?
sgn = sign(1_pInt, myNgrains - sum(NgrainsOfConstituent)) ! direction of required change
extreme = 0.0_pReal
t = 0_pInt
do i = 1,microstructure_Nconstituents(micro) ! find largest deviator
if (sgn*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) > extreme) then
extreme = sgn*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro))
t = i
endif
enddo
NgrainsOfConstituent(t) = NgrainsOfConstituent(t) + sgn ! change that by one
end do
write (6,*) 'fixed NgrainsOfConstituent',NgrainsOfConstituent
! ----------------------------------------------------------------------------
phaseOfGrain = 0_pInt
orientationOfGrain = 0.0_pReal
grain = 0_pInt ! reset microstructure grain index
do i = 1,microstructure_Nconstituents(micro) ! loop over constituents
phaseID = microstructure_phase(i,micro)
textureID = microstructure_texture(i,micro)
phaseOfGrain(grain+1:grain+NgrainsOfConstituent(i)) = phaseID ! assign resp. phase
myNorientations = ceiling(float(NgrainsOfConstituent(i))/texture_symmetry(textureID)) ! max number of unique orientations (excl. symmetry)
write (6,'(a32,x,i6,x,f5.3,x,i6)') &
phase_name(phaseID),NgrainsOfConstituent(i),real(NgrainsOfConstituent(i)/myNgrains),myNorientations
constituentGrain = 0_pInt ! constituent grain index
! ---------
if (texture_ODFfile(textureID) == '') then ! dealing with texture components
! ---------
do t = 1,texture_Ngauss(textureID) ! loop over Gauss components
write (6,*) 'gauss',t,int(myNorientations*texture_Gauss(5,t,textureID))
do g = 1,int(myNorientations*texture_Gauss(5,t,textureID)) ! loop over required grain count
orientationOfGrain(:,grain+constituentGrain+g) = &
math_sampleGaussOri(texture_Gauss(1:3,t,textureID),&
texture_Gauss( 4,t,textureID))
enddo
constituentGrain = constituentGrain + int(myNorientations*texture_Gauss(5,t,textureID))
write (6,*) 'now at constituent grain',constituentGrain
enddo
do t = 1,texture_Nfiber(textureID) ! loop over fiber components
write (6,*) 'fiber',t,int(myNorientations*texture_Fiber(6,t,textureID))
do g = 1,int(myNorientations*texture_Fiber(6,t,textureID)) ! loop over required grain count
orientationOfGrain(:,grain+constituentGrain+g) = &
math_sampleFiberOri(texture_Fiber(1:2,t,textureID),&
texture_Fiber(3:4,t,textureID),&
texture_Fiber( 5,t,textureID))
enddo
constituentGrain = constituentGrain + int(myNorientations*texture_fiber(6,t,textureID))
write (6,*) 'now at constituent grain',constituentGrain
enddo
write (6,*) 'looping',constituentGrain+1,myNorientations
do j = constituentGrain+1,myNorientations ! fill remainder with random
orientationOfGrain(:,grain+j) = math_sampleRandomOri()
enddo
write (6,*) 'done...'
! ---------
else ! hybrid IA
! ---------
orientationOfGrain(:,grain+1:grain+myNorientations) = IO_hybridIA(myNorientations,texture_ODFfile(textureID))
if (all(orientationOfGrain(:,grain+1) == -1.0_pReal)) call IO_error(105)
constituentGrain = constituentGrain + myNorientations
endif
! ----------------------------------------------------------------------------
symExtension = texture_symmetry(textureID) - 1_pInt
if (symExtension > 0_pInt) then ! sample symmetry
constituentGrain = NgrainsOfConstituent(i)-myNorientations ! calc remainder of array
do j = 1,myNorientations ! loop over each "real" orientation
symOrientation = math_symmetricEulers(texture_symmetry(textureID),orientationOfGrain(:,j)) ! get symmetric equivalents
e = min(symExtension,constituentGrain) ! are we at end of constituent grain array?
if (e > 0_pInt) then
orientationOfGrain(:,grain+myNorientations+1+(j-1)*symExtension:&
grain+myNorientations+e+(j-1)*symExtension) = &
symOrientation(:,1:e)
constituentGrain = constituentGrain - e ! remainder shrinks by e
endif
enddo
endif
grain = grain + NgrainsOfConstituent(i) ! advance microstructure grain index
end do ! constituent
! ----------------------------------------------------------------------------
do i=1,myNgrains-1 ! walk thru grains
call random_number(rnd)
t = nint(rnd*(myNgrains-i)+i+0.5_pReal,pInt) ! select a grain in remaining list
m = phaseOfGrain(t) ! exchange current with random
phaseOfGrain(t) = phaseOfGrain(i)
phaseOfGrain(i) = m
orientation = orientationOfGrain(:,t)
orientationOfGrain(:,t) = orientationOfGrain(:,i)
orientationOfGrain(:,i) = orientation
end do
!calc fraction after weighing with volumePerGrain
!exchange in MC steps to improve result...
! ----------------------------------------------------------------------------
!write(6,*) ''
!write(6,*) 'USER DEFINED OUTPUT'
!write(6,'(7(a10,x),a10)') 'element','ip','Ngrains','volFrac','phase','phi1','Phi','phi2'
grain = 0_pInt ! microstructure grain index
do e = 1,mesh_NcpElems ! check each element
if (mesh_element(3,e) == homog .and. mesh_element(4,e) == micro) then ! my combination of homog and micro
forall (i = 1:FE_Nips(mesh_element(2,e)), g = 1:dGrains) ! loop over IPs and grains
material_volFrac(g,i,e) = volFracOfGrain(grain+(i-1)*dGrains+g)
material_phase(g,i,e) = phaseOfGrain(grain+(i-1)*dGrains+g)
material_EulerAngles(:,g,i,e) = orientationOfGrain(:,grain+(i-1)*dGrains+g)
end forall
!do i = 1,FE_Nips(mesh_element(2,e))
! write(6,'(3(i10,x),e10.3,x,i10,x,3(f10.1,x))') e, i, dGrains, sum(material_volFrac(:,i,e)), &
! sum(material_phase(:,i,e)), &
! sum(material_EulerAngles(1,:,i,e)), &
! sum(material_EulerAngles(2,:,i,e)), &
! sum(material_EulerAngles(3,:,i,e))
!end do
grain = grain + FE_Nips(mesh_element(2,e)) * dGrains ! wind forward by Nips*NgrainsPerIP
endif
enddo
endif ! active homog,micro pair
enddo
enddo
deallocate(volFracOfGrain)
deallocate(phaseOfGrain)
deallocate(orientationOfGrain)
return
end subroutine
END MODULE

2397
patch/subroutine/math.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

1765
patch/subroutine/mesh.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

3043
patch/subroutine/mesh_ck.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

3017
patch/subroutine/mesh_new.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

1565
patch/subroutine/mesh_old.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

306
patch/subroutine/mpie_cpfem_marc.f90 Normal file
View File

@ -0,0 +1,306 @@
!********************************************************************
! Material subroutine for MSC.Marc
!
! written by P. Eisenlohr,
! F. Roters,
! L. Hantcherli,
! W.A. Counts
! D.D. Tjahjanto
!
! MPI fuer Eisenforschung, Duesseldorf
!
!********************************************************************
! Usage:
! - choose material as hypela2
! - set statevariable 2 to index of homogenization
! - set statevariable 3 to index of microstructure
! - make sure the file "material.config" exists in the working
! directory
! - use nonsymmetric option for solver (e.g. direct
! profile or multifrontal sparse, the latter seems
! to be faster!)
! - in case of ddm (domain decomposition)a SYMMETRIC
! solver has to be used, i.e uncheck "non-symmetric"
!********************************************************************
! Marc subroutines used:
! - hypela2
! - plotv
! - quit
!********************************************************************
! Marc common blocks included:
! - concom: lovl, ncycle, inc, incsub
! - creeps: timinc
!********************************************************************
!
include "prec.f90" ! uses nothing else
include "debug.f90" ! uses prec
include "math.f90" ! uses prec
include "IO.f90" ! uses prec, debug, math
include "FEsolving.f90" ! uses prec, IO
include "mesh.f90" ! uses prec, IO, math, FEsolving
include "material.f90" ! uses prec, math, IO, mesh
include "lattice.f90" ! uses prec, math
include "constitutive_phenomenological.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_j2.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_dislobased.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive.f90" ! uses prec, IO, math, lattice, mesh, debug
include "CPFEM.f90" ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
SUBROUTINE hypela2(d,g,e,de,s,t,dt,ngens,n,nn,kcus,matus,ndi,&
nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,&
frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,&
nnode,jtype,lclass,ifr,ifu)
!********************************************************************
! This is the Marc material routine
!********************************************************************
!
! ************* user subroutine for defining material behavior **************
!
!
! CAUTION : Due to calculation of the Deformation gradients, Stretch Tensors and
! Rotation tensors at previous and current states, the analysis can be
! computationally expensive. Please use the user subroutine -> hypela
! if these kinematic quantities are not needed in the constitutive model
!
!
! IMPORTANT NOTES :
!
! (1) F,R,U are only available for continuum and membrane elements (not for
! shells and beams).
!
! (2) For total Lagrangian formulation use the -> 'Elasticity,1' card(=
! total Lagrange with large disp) in the parameter section of input deck.
! For updated Lagrangian formulation use the -> 'Plasticity,3' card(=
! update+finite+large disp+constant d) in the parameter section of
! input deck.
!
!
! d stress strain law to be formed
! g change in stress due to temperature effects
! e total elastic strain
! de increment of strain
! s stress - should be updated by user
! t state variables (comes in at t=n, must be updated
! to have state variables at t=n+1)
! dt increment of state variables
! ngens size of stress - strain law
! n element number
! nn integration point number
! kcus(1) layer number
! kcus(2) internal layer number
! matus(1) user material identification number
! matus(2) internal material identification number
! ndi number of direct components
! nshear number of shear components
! disp incremental displacements
! dispt displacements at t=n (at assembly, lovl=4) and
! displacements at t=n+1 (at stress recovery, lovl=6)
! coord coordinates
! ncrd number of coordinates
! ndeg number of degrees of freedom
! itel dimension of F and R, either 2 or 3
! nnode number of nodes per element
! jtype element type
! lclass element class
! ifr set to 1 if R has been calculated
! ifu set to 1 if strech has been calculated
!
! at t=n :
!
! ffn deformation gradient
! frotn rotation tensor
! strechn square of principal stretch ratios, lambda(i)
! eigvn(i,j) i principal direction components for j eigenvalues
!
! at t=n+1 :
!
! ffn1 deformation gradient
! frotn1 rotation tensor
! strechn1 square of principal stretch ratios, lambda(i)
! eigvn1(i,j) i principal direction components for j eigenvalues
!
! The following operation obtains U (stretch tensor) at t=n+1 :
!
! call scla(un1,0.d0,itel,itel,1)
! do 3 k=1,3
! do 2 i=1,3
! do 1 j=1,3
! un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k)
!1 continue
!2 continue
!3 continue
!
use prec, only: pReal,pInt, ijaco
use FEsolving
use CPFEM, only: CPFEM_general
use math, only: invnrmMandel
use debug
!
implicit none
! ** Start of generated type statements **
real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
real(pReal) frotn, frotn1, g
integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
real(pReal) s, strechn, strechn1, t
! ** End of generated type statements **
!
dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2)
! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
! Beware of changes in newer Marc versions
include "concom%%MARCVERSION%%" ! concom is needed for inc, subinc, ncycle, lovl
include "creeps%%MARCVERSION%%" ! creeps is needed for timinc (time increment)
integer(pInt) computationMode,i
! write(6,'(3(3(f10.3,x),/))') ffn1(:,1),ffn1(:,2),ffn1(:,3)
if (inc == 0) then
cycleCounter = 4
else
if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0 ! reset counter for each cutback or new inc
if (theCycle /= ncycle .or. theLovl /= lovl) then
cycleCounter = cycleCounter+1 ! ping pong
outdatedFFN1 = .false.
write (6,*) n(1),nn,'cycleCounter',cycleCounter
call debug_info() ! output of debugging/performance statistics of former
debug_cutbackDistribution = 0_pInt ! initialize debugging data
debug_InnerLoopDistribution = 0_pInt
debug_OuterLoopDistribution = 0_pInt
debug_cumLpTicks = 0
debug_cumDotStateTicks = 0
debug_cumLpCalls = 0_pInt
debug_cumDotStateCalls = 0_pInt
endif
endif
if (cptim > theTime .or. theInc /= inc) then ! reached convergence
lastIncConverged = .true.
outdatedByNewInc = .true.
write (6,*) n(1),nn,'lastIncConverged + outdated'
endif
if (mod(cycleCounter,2) /= 0) computationMode = 4 ! recycle in odd cycles
if (mod(cycleCounter,4) == 2) computationMode = 3 ! collect in 2,6,10,...
if (mod(cycleCounter,4) == 0) computationMode = 2 ! compute in 0,4,8,...
if (computationMode == 4 .and. ncycle == 0 .and. .not. lastIncConverged) &
computationMode = 6 ! recycle but restore known good consistent tangent
if (computationMode == 4 .and. lastIncConverged) then
computationMode = 5 ! recycle and record former consistent tangent
lastIncConverged = .false.
endif
if (computationMode == 2 .and. outdatedByNewInc) then
computationMode = 1 ! compute and age former results
outdatedByNewInc = .false.
endif
theTime = cptim ! record current starting time
theInc = inc ! record current increment number
theCycle = ncycle ! record current cycle count
theLovl = lovl ! record current lovl
call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
! Marc: 11, 22, 33, 12, 23, 13
forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
s(1:ngens) = s(1:ngens)*invnrmMandel(1:ngens)
if(symmetricSolver) d(1:ngens,1:ngens) = 0.5_pReal*(d(1:ngens,1:ngens)+transpose(d(1:ngens,1:ngens)))
return
END SUBROUTINE
!
SUBROUTINE plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd)
!********************************************************************
! This routine sets user defined output variables for Marc
!********************************************************************
!
! select a variable contour plotting (user subroutine).
!
! v variable
! s (idss) stress array
! sp stresses in preferred direction
! etot total strain (generalized)
! eplas total plastic strain
! ecreep total creep strain
! t current temperature
! m element number
! nn integration point number
! layer layer number
! ndi (3) number of direct stress components
! nshear (3) number of shear stress components
!
!********************************************************************
use prec, only: pReal,pInt
use CPFEM, only: CPFEM_results, CPFEM_Nresults
use constitutive, only: constitutive_maxSizePostResults
use mesh, only: mesh_FEasCP
implicit none
!
real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*)
real(pReal) v, t(*)
integer(pInt) m, nn, layer, ndi, nshear, jpltcd
!
! assign result variable
v = CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
(jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
nn, mesh_FEasCP('elem', m))
return
END SUBROUTINE
!
!
! subroutine utimestep(timestep,timestepold,icall,time,timeloadcase)
!********************************************************************
! This routine modifies the addaptive time step of Marc
!********************************************************************
! use prec, only: pReal,pInt
! use CPFEM, only : CPFEM_timefactor_max
! implicit none
!
! real(pReal) timestep, timestepold, time,timeloadcase
! integer(pInt) icall
!
! user subroutine for modifying the time step in auto step
!
! timestep : the current time step as suggested by marc
! to be modified in this routine
! timestepold : the current time step before it was modified by marc
! icall : =1 for setting the initial time step
! =2 if this routine is called during an increment
! =3 if this routine is called at the beginning
! of the increment
! time : time at the start of the current increment
! timeloadcase: time period of the current load case
!
! it is in general not recommended to increase the time step
! during the increment.
! this routine is called right after the time step has (possibly)
! been updated by marc.
!
! user coding
! reduce timestep during increment in case mpie_timefactor is too large
! if(icall==2_pInt) then
! if(mpie_timefactor_max>1.25_pReal) then
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! return
! modify timestep at beginning of new increment
! else if(icall==3_pInt) then
! if(mpie_timefactor_max<=0.8_pReal) then
! timestep=min(timestep,timestepold*1.25_pReal)
! else if (mpie_timefactor_max<=1.0_pReal) then
! timestep=min(timestep,timestepold/mpie_timefactor_max)
! else if (mpie_timefactor_max<=1.25_pReal) then
! timestep=min(timestep,timestepold*1.01_pReal)
! else
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! end if
! return
! end

306
patch/subroutine/mpie_cpfem_marc2007r1.f90 Normal file
View File

@ -0,0 +1,306 @@
!********************************************************************
! Material subroutine for MSC.Marc
!
! written by P. Eisenlohr,
! F. Roters,
! L. Hantcherli,
! W.A. Counts
! D.D. Tjahjanto
!
! MPI fuer Eisenforschung, Duesseldorf
!
!********************************************************************
! Usage:
! - choose material as hypela2
! - set statevariable 2 to index of homogenization
! - set statevariable 3 to index of microstructure
! - make sure the file "material.config" exists in the working
! directory
! - use nonsymmetric option for solver (e.g. direct
! profile or multifrontal sparse, the latter seems
! to be faster!)
! - in case of ddm (domain decomposition)a SYMMETRIC
! solver has to be used, i.e uncheck "non-symmetric"
!********************************************************************
! Marc subroutines used:
! - hypela2
! - plotv
! - quit
!********************************************************************
! Marc common blocks included:
! - concom: lovl, ncycle, inc, incsub
! - creeps: timinc
!********************************************************************
!
include "prec.f90" ! uses nothing else
include "debug.f90" ! uses prec
include "math.f90" ! uses prec
include "IO.f90" ! uses prec, debug, math
include "FEsolving.f90" ! uses prec, IO
include "mesh.f90" ! uses prec, IO, math, FEsolving
include "material.f90" ! uses prec, math, IO, mesh
include "lattice.f90" ! uses prec, math
include "constitutive_phenomenological.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_j2.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_dislobased.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive.f90" ! uses prec, IO, math, lattice, mesh, debug
include "CPFEM.f90" ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
SUBROUTINE hypela2(d,g,e,de,s,t,dt,ngens,n,nn,kcus,matus,ndi,&
nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,&
frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,&
nnode,jtype,lclass,ifr,ifu)
!********************************************************************
! This is the Marc material routine
!********************************************************************
!
! ************* user subroutine for defining material behavior **************
!
!
! CAUTION : Due to calculation of the Deformation gradients, Stretch Tensors and
! Rotation tensors at previous and current states, the analysis can be
! computationally expensive. Please use the user subroutine -> hypela
! if these kinematic quantities are not needed in the constitutive model
!
!
! IMPORTANT NOTES :
!
! (1) F,R,U are only available for continuum and membrane elements (not for
! shells and beams).
!
! (2) For total Lagrangian formulation use the -> 'Elasticity,1' card(=
! total Lagrange with large disp) in the parameter section of input deck.
! For updated Lagrangian formulation use the -> 'Plasticity,3' card(=
! update+finite+large disp+constant d) in the parameter section of
! input deck.
!
!
! d stress strain law to be formed
! g change in stress due to temperature effects
! e total elastic strain
! de increment of strain
! s stress - should be updated by user
! t state variables (comes in at t=n, must be updated
! to have state variables at t=n+1)
! dt increment of state variables
! ngens size of stress - strain law
! n element number
! nn integration point number
! kcus(1) layer number
! kcus(2) internal layer number
! matus(1) user material identification number
! matus(2) internal material identification number
! ndi number of direct components
! nshear number of shear components
! disp incremental displacements
! dispt displacements at t=n (at assembly, lovl=4) and
! displacements at t=n+1 (at stress recovery, lovl=6)
! coord coordinates
! ncrd number of coordinates
! ndeg number of degrees of freedom
! itel dimension of F and R, either 2 or 3
! nnode number of nodes per element
! jtype element type
! lclass element class
! ifr set to 1 if R has been calculated
! ifu set to 1 if strech has been calculated
!
! at t=n :
!
! ffn deformation gradient
! frotn rotation tensor
! strechn square of principal stretch ratios, lambda(i)
! eigvn(i,j) i principal direction components for j eigenvalues
!
! at t=n+1 :
!
! ffn1 deformation gradient
! frotn1 rotation tensor
! strechn1 square of principal stretch ratios, lambda(i)
! eigvn1(i,j) i principal direction components for j eigenvalues
!
! The following operation obtains U (stretch tensor) at t=n+1 :
!
! call scla(un1,0.d0,itel,itel,1)
! do 3 k=1,3
! do 2 i=1,3
! do 1 j=1,3
! un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k)
!1 continue
!2 continue
!3 continue
!
use prec, only: pReal,pInt, ijaco
use FEsolving
use CPFEM, only: CPFEM_general
use math, only: invnrmMandel
use debug
!
implicit none
! ** Start of generated type statements **
real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
real(pReal) frotn, frotn1, g
integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
real(pReal) s, strechn, strechn1, t
! ** End of generated type statements **
!
dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2)
! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
! Beware of changes in newer Marc versions
include "concom2007r1" ! concom is needed for inc, subinc, ncycle, lovl
include "creeps2007r1" ! creeps is needed for timinc (time increment)
integer(pInt) computationMode,i
! write(6,'(3(3(f10.3,x),/))') ffn1(:,1),ffn1(:,2),ffn1(:,3)
if (inc == 0) then
cycleCounter = 4
else
if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0 ! reset counter for each cutback or new inc
if (theCycle /= ncycle .or. theLovl /= lovl) then
cycleCounter = cycleCounter+1 ! ping pong
outdatedFFN1 = .false.
write (6,*) n(1),nn,'cycleCounter',cycleCounter
call debug_info() ! output of debugging/performance statistics of former
debug_cutbackDistribution = 0_pInt ! initialize debugging data
debug_InnerLoopDistribution = 0_pInt
debug_OuterLoopDistribution = 0_pInt
debug_cumLpTicks = 0
debug_cumDotStateTicks = 0
debug_cumLpCalls = 0_pInt
debug_cumDotStateCalls = 0_pInt
endif
endif
if (cptim > theTime .or. theInc /= inc) then ! reached convergence
lastIncConverged = .true.
outdatedByNewInc = .true.
write (6,*) n(1),nn,'lastIncConverged + outdated'
endif
if (mod(cycleCounter,2) /= 0) computationMode = 4 ! recycle in odd cycles
if (mod(cycleCounter,4) == 2) computationMode = 3 ! collect in 2,6,10,...
if (mod(cycleCounter,4) == 0) computationMode = 2 ! compute in 0,4,8,...
if (computationMode == 4 .and. ncycle == 0 .and. .not. lastIncConverged) &
computationMode = 6 ! recycle but restore known good consistent tangent
if (computationMode == 4 .and. lastIncConverged) then
computationMode = 5 ! recycle and record former consistent tangent
lastIncConverged = .false.
endif
if (computationMode == 2 .and. outdatedByNewInc) then
computationMode = 1 ! compute and age former results
outdatedByNewInc = .false.
endif
theTime = cptim ! record current starting time
theInc = inc ! record current increment number
theCycle = ncycle ! record current cycle count
theLovl = lovl ! record current lovl
call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
! Marc: 11, 22, 33, 12, 23, 13
forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
s(1:ngens) = s(1:ngens)*invnrmMandel(1:ngens)
if(symmetricSolver) d(1:ngens,1:ngens) = 0.5_pReal*(d(1:ngens,1:ngens)+transpose(d(1:ngens,1:ngens)))
return
END SUBROUTINE
!
SUBROUTINE plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd)
!********************************************************************
! This routine sets user defined output variables for Marc
!********************************************************************
!
! select a variable contour plotting (user subroutine).
!
! v variable
! s (idss) stress array
! sp stresses in preferred direction
! etot total strain (generalized)
! eplas total plastic strain
! ecreep total creep strain
! t current temperature
! m element number
! nn integration point number
! layer layer number
! ndi (3) number of direct stress components
! nshear (3) number of shear stress components
!
!********************************************************************
use prec, only: pReal,pInt
use CPFEM, only: CPFEM_results, CPFEM_Nresults
use constitutive, only: constitutive_maxSizePostResults
use mesh, only: mesh_FEasCP
implicit none
!
real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*)
real(pReal) v, t(*)
integer(pInt) m, nn, layer, ndi, nshear, jpltcd
!
! assign result variable
v = CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
(jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
nn, mesh_FEasCP('elem', m))
return
END SUBROUTINE
!
!
! subroutine utimestep(timestep,timestepold,icall,time,timeloadcase)
!********************************************************************
! This routine modifies the addaptive time step of Marc
!********************************************************************
! use prec, only: pReal,pInt
! use CPFEM, only : CPFEM_timefactor_max
! implicit none
!
! real(pReal) timestep, timestepold, time,timeloadcase
! integer(pInt) icall
!
! user subroutine for modifying the time step in auto step
!
! timestep : the current time step as suggested by marc
! to be modified in this routine
! timestepold : the current time step before it was modified by marc
! icall : =1 for setting the initial time step
! =2 if this routine is called during an increment
! =3 if this routine is called at the beginning
! of the increment
! time : time at the start of the current increment
! timeloadcase: time period of the current load case
!
! it is in general not recommended to increase the time step
! during the increment.
! this routine is called right after the time step has (possibly)
! been updated by marc.
!
! user coding
! reduce timestep during increment in case mpie_timefactor is too large
! if(icall==2_pInt) then
! if(mpie_timefactor_max>1.25_pReal) then
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! return
! modify timestep at beginning of new increment
! else if(icall==3_pInt) then
! if(mpie_timefactor_max<=0.8_pReal) then
! timestep=min(timestep,timestepold*1.25_pReal)
! else if (mpie_timefactor_max<=1.0_pReal) then
! timestep=min(timestep,timestepold/mpie_timefactor_max)
! else if (mpie_timefactor_max<=1.25_pReal) then
! timestep=min(timestep,timestepold*1.01_pReal)
! else
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! end if
! return
! end

BIN
patch/subroutine/mpie_cpfem_marc2007r1.marc Normal file
View File

Binary file not shown.

306
patch/subroutine/mpie_cpfem_marc2008r1.f90 Normal file
View File

@ -0,0 +1,306 @@
!********************************************************************
! Material subroutine for MSC.Marc
!
! written by P. Eisenlohr,
! F. Roters,
! L. Hantcherli,
! W.A. Counts
! D.D. Tjahjanto
!
! MPI fuer Eisenforschung, Duesseldorf
!
!********************************************************************
! Usage:
! - choose material as hypela2
! - set statevariable 2 to index of homogenization
! - set statevariable 3 to index of microstructure
! - make sure the file "material.config" exists in the working
! directory
! - use nonsymmetric option for solver (e.g. direct
! profile or multifrontal sparse, the latter seems
! to be faster!)
! - in case of ddm (domain decomposition)a SYMMETRIC
! solver has to be used, i.e uncheck "non-symmetric"
!********************************************************************
! Marc subroutines used:
! - hypela2
! - plotv
! - quit
!********************************************************************
! Marc common blocks included:
! - concom: lovl, ncycle, inc, incsub
! - creeps: timinc
!********************************************************************
!
include "prec.f90" ! uses nothing else
include "debug.f90" ! uses prec
include "math.f90" ! uses prec
include "IO.f90" ! uses prec, debug, math
include "FEsolving.f90" ! uses prec, IO
include "mesh.f90" ! uses prec, IO, math, FEsolving
include "material.f90" ! uses prec, math, IO, mesh
include "lattice.f90" ! uses prec, math
include "constitutive_phenomenological.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_j2.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive_dislobased.f90" ! uses prec, math, IO, lattice, material, debug
include "constitutive.f90" ! uses prec, IO, math, lattice, mesh, debug
include "CPFEM.f90" ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
SUBROUTINE hypela2(d,g,e,de,s,t,dt,ngens,n,nn,kcus,matus,ndi,&
nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,&
frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,&
nnode,jtype,lclass,ifr,ifu)
!********************************************************************
! This is the Marc material routine
!********************************************************************
!
! ************* user subroutine for defining material behavior **************
!
!
! CAUTION : Due to calculation of the Deformation gradients, Stretch Tensors and
! Rotation tensors at previous and current states, the analysis can be
! computationally expensive. Please use the user subroutine -> hypela
! if these kinematic quantities are not needed in the constitutive model
!
!
! IMPORTANT NOTES :
!
! (1) F,R,U are only available for continuum and membrane elements (not for
! shells and beams).
!
! (2) For total Lagrangian formulation use the -> 'Elasticity,1' card(=
! total Lagrange with large disp) in the parameter section of input deck.
! For updated Lagrangian formulation use the -> 'Plasticity,3' card(=
! update+finite+large disp+constant d) in the parameter section of
! input deck.
!
!
! d stress strain law to be formed
! g change in stress due to temperature effects
! e total elastic strain
! de increment of strain
! s stress - should be updated by user
! t state variables (comes in at t=n, must be updated
! to have state variables at t=n+1)
! dt increment of state variables
! ngens size of stress - strain law
! n element number
! nn integration point number
! kcus(1) layer number
! kcus(2) internal layer number
! matus(1) user material identification number
! matus(2) internal material identification number
! ndi number of direct components
! nshear number of shear components
! disp incremental displacements
! dispt displacements at t=n (at assembly, lovl=4) and
! displacements at t=n+1 (at stress recovery, lovl=6)
! coord coordinates
! ncrd number of coordinates
! ndeg number of degrees of freedom
! itel dimension of F and R, either 2 or 3
! nnode number of nodes per element
! jtype element type
! lclass element class
! ifr set to 1 if R has been calculated
! ifu set to 1 if strech has been calculated
!
! at t=n :
!
! ffn deformation gradient
! frotn rotation tensor
! strechn square of principal stretch ratios, lambda(i)
! eigvn(i,j) i principal direction components for j eigenvalues
!
! at t=n+1 :
!
! ffn1 deformation gradient
! frotn1 rotation tensor
! strechn1 square of principal stretch ratios, lambda(i)
! eigvn1(i,j) i principal direction components for j eigenvalues
!
! The following operation obtains U (stretch tensor) at t=n+1 :
!
! call scla(un1,0.d0,itel,itel,1)
! do 3 k=1,3
! do 2 i=1,3
! do 1 j=1,3
! un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k)
!1 continue
!2 continue
!3 continue
!
use prec, only: pReal,pInt, ijaco
use FEsolving
use CPFEM, only: CPFEM_general
use math, only: invnrmMandel
use debug
!
implicit none
! ** Start of generated type statements **
real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
real(pReal) frotn, frotn1, g
integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
real(pReal) s, strechn, strechn1, t
! ** End of generated type statements **
!
dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2)
! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
! Beware of changes in newer Marc versions
include "concom2008r1" ! concom is needed for inc, subinc, ncycle, lovl
include "creeps2008r1" ! creeps is needed for timinc (time increment)
integer(pInt) computationMode,i
! write(6,'(3(3(f10.3,x),/))') ffn1(:,1),ffn1(:,2),ffn1(:,3)
if (inc == 0) then
cycleCounter = 4
else
if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0 ! reset counter for each cutback or new inc
if (theCycle /= ncycle .or. theLovl /= lovl) then
cycleCounter = cycleCounter+1 ! ping pong
outdatedFFN1 = .false.
write (6,*) n(1),nn,'cycleCounter',cycleCounter
call debug_info() ! output of debugging/performance statistics of former
debug_cutbackDistribution = 0_pInt ! initialize debugging data
debug_InnerLoopDistribution = 0_pInt
debug_OuterLoopDistribution = 0_pInt
debug_cumLpTicks = 0
debug_cumDotStateTicks = 0
debug_cumLpCalls = 0_pInt
debug_cumDotStateCalls = 0_pInt
endif
endif
if (cptim > theTime .or. theInc /= inc) then ! reached convergence
lastIncConverged = .true.
outdatedByNewInc = .true.
write (6,*) n(1),nn,'lastIncConverged + outdated'
endif
if (mod(cycleCounter,2) /= 0) computationMode = 4 ! recycle in odd cycles
if (mod(cycleCounter,4) == 2) computationMode = 3 ! collect in 2,6,10,...
if (mod(cycleCounter,4) == 0) computationMode = 2 ! compute in 0,4,8,...
if (computationMode == 4 .and. ncycle == 0 .and. .not. lastIncConverged) &
computationMode = 6 ! recycle but restore known good consistent tangent
if (computationMode == 4 .and. lastIncConverged) then
computationMode = 5 ! recycle and record former consistent tangent
lastIncConverged = .false.
endif
if (computationMode == 2 .and. outdatedByNewInc) then
computationMode = 1 ! compute and age former results
outdatedByNewInc = .false.
endif
theTime = cptim ! record current starting time
theInc = inc ! record current increment number
theCycle = ncycle ! record current cycle count
theLovl = lovl ! record current lovl
call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
! Marc: 11, 22, 33, 12, 23, 13
forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
s(1:ngens) = s(1:ngens)*invnrmMandel(1:ngens)
if(symmetricSolver) d(1:ngens,1:ngens) = 0.5_pReal*(d(1:ngens,1:ngens)+transpose(d(1:ngens,1:ngens)))
return
END SUBROUTINE
!
SUBROUTINE plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd)
!********************************************************************
! This routine sets user defined output variables for Marc
!********************************************************************
!
! select a variable contour plotting (user subroutine).
!
! v variable
! s (idss) stress array
! sp stresses in preferred direction
! etot total strain (generalized)
! eplas total plastic strain
! ecreep total creep strain
! t current temperature
! m element number
! nn integration point number
! layer layer number
! ndi (3) number of direct stress components
! nshear (3) number of shear stress components
!
!********************************************************************
use prec, only: pReal,pInt
use CPFEM, only: CPFEM_results, CPFEM_Nresults
use constitutive, only: constitutive_maxSizePostResults
use mesh, only: mesh_FEasCP
implicit none
!
real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*)
real(pReal) v, t(*)
integer(pInt) m, nn, layer, ndi, nshear, jpltcd
!
! assign result variable
v = CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
(jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxSizePostResults)+1_pInt,&
nn, mesh_FEasCP('elem', m))
return
END SUBROUTINE
!
!
! subroutine utimestep(timestep,timestepold,icall,time,timeloadcase)
!********************************************************************
! This routine modifies the addaptive time step of Marc
!********************************************************************
! use prec, only: pReal,pInt
! use CPFEM, only : CPFEM_timefactor_max
! implicit none
!
! real(pReal) timestep, timestepold, time,timeloadcase
! integer(pInt) icall
!
! user subroutine for modifying the time step in auto step
!
! timestep : the current time step as suggested by marc
! to be modified in this routine
! timestepold : the current time step before it was modified by marc
! icall : =1 for setting the initial time step
! =2 if this routine is called during an increment
! =3 if this routine is called at the beginning
! of the increment
! time : time at the start of the current increment
! timeloadcase: time period of the current load case
!
! it is in general not recommended to increase the time step
! during the increment.
! this routine is called right after the time step has (possibly)
! been updated by marc.
!
! user coding
! reduce timestep during increment in case mpie_timefactor is too large
! if(icall==2_pInt) then
! if(mpie_timefactor_max>1.25_pReal) then
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! return
! modify timestep at beginning of new increment
! else if(icall==3_pInt) then
! if(mpie_timefactor_max<=0.8_pReal) then
! timestep=min(timestep,timestepold*1.25_pReal)
! else if (mpie_timefactor_max<=1.0_pReal) then
! timestep=min(timestep,timestepold/mpie_timefactor_max)
! else if (mpie_timefactor_max<=1.25_pReal) then
! timestep=min(timestep,timestepold*1.01_pReal)
! else
! timestep=min(timestep,timestepold*0.8_pReal)
! end if
! end if
! return
! end

BIN
patch/subroutine/mpie_cpfem_marc2008r1.marc Normal file
View File

Binary file not shown.

38
patch/subroutine/prec.f90 Normal file
View File

@ -0,0 +1,38 @@
!##############################################################
MODULE prec
!##############################################################
implicit none
! *** Precision of real and integer variables ***
integer, parameter :: pReal = selected_real_kind(15,300) ! 15 significant digits, up to 1e+-300
integer, parameter :: pInt = selected_int_kind(9) ! up to +- 1e9
integer, parameter :: pLongInt = 8 ! should be 64bit
type :: p_vec
real(pReal), dimension(:), pointer :: p
end type p_vec
! *** Strain increment considered significant ***
real(pReal), parameter :: relevantStrain = 1.0e-7_pReal
! *** Numerical parameters ***
integer(pInt), parameter :: ijaco = 1_pInt ! frequency of FEM Jacobi update
integer(pInt), parameter :: nCutback = 20_pInt ! max cutbacks accounted for in debug distribution
integer(pInt), parameter :: nReg = 1_pInt ! regularization attempts for Jacobi inversion
real(pReal), parameter :: pert_Fg = 1.0e-6_pReal ! strain perturbation for FEM Jacobi
integer(pInt), parameter :: nOuter = 20_pInt ! outer loop limit 20
integer(pInt), parameter :: nInner = 200_pInt ! inner loop limit 200
real(pReal), parameter :: reltol_Outer = 1.0e-5_pReal ! relative tolerance in outer loop (state)
real(pReal), parameter :: reltol_Inner = 1.0e-6_pReal ! relative tolerance in inner loop (Lp)
real(pReal), parameter :: abstol_Inner = 1.0e-8_pReal ! absolute tolerance in inner loop (Lp)
!
real(pReal), parameter :: resToler = 1.0e-4_pReal ! relative tolerance of residual in GIA iteration
real(pReal), parameter :: resAbsol = 1.0e+2_pReal ! absolute tolerance of residual in GIA iteration (corresponds to ~1 Pa)
real(pReal), parameter :: resBound = 1.0e+1_pReal ! relative maximum value (upper bound) for GIA residual
integer(pInt), parameter :: NRiterMax = 24_pInt ! maximum number of GIA iteration
real(pReal), parameter :: subStepMin = 1.0e-3_pReal ! minimum (relative) size of sub-step allowed during cutback
END MODULE prec

13
patch/subroutine/todo.txt Normal file
View File

@ -0,0 +1,13 @@
Things to be implemented into the code
# adopt CPFEM_GIA8.f90 to new scheme, use "select case" to switch between homogenization schemes in CPFEM.f90
# make OpenMP parallelization work again
# adopt constitutive_dislo
# check out
@phdthesis{Bal98,
Author = {Balasubramanian, Srihari},
School = {Massachusetts Institute of Technology},
Title = {Polycrystalline Plasticity: Application to Deformation Processing of Lightweight Metals},
Year = {1998}}
for an analytical way to calculate the Jacobian matrix instead of the numerical perturbation technique currently employed.