phd-scripts/Unpublished/XFEM2/Full2D/2D_XCor.for

202 lines
5.5 KiB
Text
Raw Normal View History

2024-05-13 19:50:21 +00:00
c 2D XFEM Corrosion Element
subroutine uel(rhs,amatrx,svars,energy,ndofel,nrhs,nsvars,props,
1 nprops,coords,mcrd,nnode,u,du,v,a,jtype,time,dtime,kstep,kinc,
2 jelem,params,ndload,jdltyp,adlmag,predef,npredf,lflags,
3 mlvarx,ddlmag,mdload,pnewdt,jprops,njprop,period)
c
include 'aba_param.inc'
c
dimension rhs(mlvarx,*),amatrx(ndofel,ndofel),svars(nsvars),
1 energy(8),props(*),coords(mcrd,nnode),
2 u(ndofel),du(mlvarx,*),v(ndofel),a(ndofel),time(2),
3 params(3),jdltyp(mdload,*),adlmag(mdload,*),
4 ddlmag(mdload,*),predef(2,npredf,nnode),lflags(*),jprops(*)
c
dimension phig(8),phih(8),phi(8),phix(8),phiy(8)
dimension crdnx(4),crdny(4),w(8),dndg(4),dndh(4)
dimension theta(4),rjac(2,2),rjaci(2,2)
c
parameter(zero=0.d0,one=1.d0)
c material property definition
thick = 1.
rho = 1.
beta=40.
vel=0.0
dpos=0.25+vel*time(2)
c initialization (nrhs=1)
do k1=1,ndofel
rhs(k1,nrhs)=zero
do k2=1,ndofel
amatrx(k2,k1)=zero
enddo
enddo
if (lflags(1).eq.33) then
do icrd=1,4
crdnx(icrd)=coords(1,icrd)
crdny(icrd)=coords(2,icrd)
theta(icrd)=abs(crdnx(icrd)-dpos)*
1 sign(1.,crdnx(icrd)-dpos)
enddo
if sign(1.,theta(1))/=sign(1.,theta(2))then
c Enriched
ienr=8
elen=abs(crdnx(2)-crdnx(1))
frac=abs(dpos-crdnx(1))/elen
rlen1=2.*frac
rlen2=2.*(1.-frac)
rmid1=-1+rlen1/2.
rmid2=1-rlen2/2.
gx(1)=rmid1-(rlen1/2.)/sqrt(3.)
gx(2)=rmid1+(rlen1/2.)/sqrt(3.)
gx(3)=rmid1+(rlen1/2.)/sqrt(3.)
gx(4)=rmid1-(rlen1/2.)/sqrt(3.)
gx(5)=rmid2-(rlen2/2.)/sqrt(3.)
gx(6)=rmid2+(rlen2/2.)/sqrt(3.)
gx(7)=rmid2+(rlen2/2.)/sqrt(3.)
gx(8)=rmid2-(rlen2/2.)/sqrt(3.)
gpos=1/sqrt(3.)
hx(1)=-gpos
hx(2)=-gpos
hx(3)=+gpos
hx(4)=+gpos
hx(5)=-gpos
hx(6)=-gpos
hx(7)=+gpos
hx(8)=+gpos
do iw=1,4
w(iw)=frac/2.;
w(iw+4)=(1.-frac)/2.;
enddo
else
c Normal Shp Funs
ienr=4
gpos=1./sqrt(3.)
gx(1)=-gpos
gx(2)=gpos
gx(3)=gpos
gx(4)=-gpos
hx(1)=-gpos
hx(2)=-gpos
hx(3)=gpos
hx(4)=gpos
do iw=1,4
w(iw)=1.
enddo
endif
c assemble amatrx and rhs
do k=1,ienr
c loop through gauss pts
g=gx(k)
h=hx(k)
phi(1)=0.25*(1.-g)*(1.-h)
phi(3)=0.25*(1.+g)*(1.-h)
phi(5)=0.25*(1.+g)*(1.+h)
phi(7)=0.25*(1.-g)*(1.+h)
riLS=theta(1)*phi(1)+theta(2)*phi(3)+
1 theta(3)*phi(5)+theta(4)*phi(7)
if (riLS<0.)then
cond=0.
spec=0.01
else
cond=1.
spec=1.
endif
do iter=1,4
phi(2*iter)=phi(2*iter-1)*
1 (abs(riLS)-abs(theta(iter)))
enddo
phig(1)=0.25*-(1.-h)
phig(3)=0.25*(1.-h)
phig(5)=0.25*(1.+h)
phig(7)=0.25*-(1.+h)
phih(1)=0.25*-(1.-g)
phih(3)=0.25*-(1.+g)
phih(5)=0.25*(1.+g)
phih(7)=0.25*(1.-g)
diLSg=sign(1.,iLS)*(phig(1)*theta(1)+phig(3)*
1 theta(2)+phig(5)*theta(3)+phig(7)*theta(4))
diLSh=sign(1.,iLS)*(phih(1)*theta(1)+phih(3)*
1 theta(2)+phih(5)*theta(3)+phih(7)*theta(4))
do iter=1,4
phig(2*iter)=phig(2*iter-1)*(abs(iLS)-
1 abs(theta(iter)))+phi(2*iter-1)*diLSg
phih(2*iter)=phih(2*iter-1)*(abs(iLS)-
1 abs(theta(iter)))+phi(2*iter-1)*diLSh
enddo
rjac=0.
do iter=1,4
rjac(1,1)=rjac(1,1)+phig(2*iter-1)*crdnx(iter)
rjac(1,2)=rjac(1,2)+phig(2*iter-1)*crdny(iter)
rjac(2,1)=rjac(2,1)+phih(2*iter-1)*crdnx(iter)
rjac(2,2)=rjac(2,2)+phih(2*iter-1)*crdny(iter)
enddo
djac=rjac(1,1)*rjac(2,2)-rjac(1,2)*rjac(2,1)
rjaci(1,1)= rjac(2,2)/djac
rjaci(2,2)= rjac(1,1)/djac
rjaci(1,2)=-rjac(1,2)/djac
rjaci(2,1)=-rjac(2,1)/djac
do iter=1,8
phix(iter)=rjaci(1,1)*phig(iter)+rjaci(1,2)*phih(iter)
phiy(iter)=rjaci(2,1)*phig(iter)+rjaci(2,2)*phih(iter)
enddo
dtdx=zero
dtdy=zero
t =zero
told=zero
do i=1,8
dtdx=u(i)*phix(i)+dtdx
dtdy=u(i)*phiy(i)+dtdy
t=u(i)*phi(i)+t
told=(u(i)-du(i,nrhs))*phi(i)+told
end do
dtdt=(t-told)/dtime
we=w(k)*djac
do ki=1,8
c loop over nodes
rhs(ki,nrhs) = rhs(ki,nrhs) -
1 we*(phi(ki)*rho*spec*dtdt +
2 cond*(phix(ki)*dtdx + phiy(ki)*dtdy))
do kj=1,8
amatrx(ki,kj)= amatrx(ki,kj) +
1 we*(phi(ki)*phi(kj)*rho*spec/dtime +
1 cond*(phix(ki)*phix(kj)+phiy(ki)*phiy(kj)))
end do
end do
enddo
c if interface is in the element a penalty term is needed
if(enr==4)then
xi=point
gm(1)=(1.-xi)/2.
gm(3)=(1.+xi)/2.
term=theta(1)*gm(1)+theta(2)*gm(3)
gm(2)=gm(1)*(abs(term)-abs(theta(1)))
gm(4)=gm(3)*(abs(term)-abs(theta(2)))
term2=gm(1)*u(1)+gm(2)*u(2)+gm(3)*u(3)+gm(4)*u(4)
diff=abs(term2-1.)
c add penalty flux/force: BGtc
targetT=1.
do i=1,4
rhs(i,nrhs)=rhs(i,nrhs)+beta*gm(i)*diff
enddo
c find GtG
gm2=0.
do i=1,4
do j=1,4
gm2(i,j)=gm(i)*gm(j)
enddo
enddo
c add penalty stiffness
do i=1,4
do j=1,4
amatrx(i,j)=amatrx(i,j)+beta*gm2(i,j)
enddo
enddo
endif
end if
return
end