phd-scripts/Unpublished/XFEM2/XFEM/htelem.for

199 lines
5.3 KiB
Text
Raw Normal View History

2024-05-13 19:50:21 +00:00
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 GPX(9),GPY(9),GWEI(9),PHI(8),PHIX(8),PHIY(8),PHIC(8),
1 PHIE(8),IFACE(9),GWE(3),AR(3)
C
PARAMETER(ZERO=0.D0,TWOHUN=200.D0,FIVHUN=500.D0,CONDUC=204.D0)
DATA IFACE/1,5,2,6,3,7,4,8,1/
C
C
C MATERIAL PROPERTY DEFINITION
C
THICK = PROPS(1)
RHO = PROPS(2)
SPEC = PROPS(3)
C
C INITIALIZATION (NRHS=1)
C
DO 6 K1=1,NDOFEL
RHS(K1,NRHS)=ZERO
DO 4 K2=1,NDOFEL
AMATRX(K2,K1)=ZERO
4 CONTINUE
6 CONTINUE
C
IF (LFLAGS(3).EQ.4) RETURN
C
C TRANSIENT ANALYSIS
C
IF (LFLAGS(1).EQ.33) THEN
C
C DETERMINE GAUSS POINT LOCATIONS
C
SUBROUTINE GSPT(GPX,GPY)
INCLUDE 'aba_param.inc'
DIMENSION AR(3),GPX(9),GPY(9)
C
PARAMETER(ZERO=0.D0,ONENEG=-1.D0,ONE=1.D0,SIX=6.D0,TEN=10.D0)
C
C GPX: X COORDINATE OF GAUSS PT
C GPY: Y COORDINATE OF GAUSS PT
C
R=SQRT(SIX/TEN)
AR(1)=-1.
AR(2)=0.
AR(3)=1.
DO 10 I=1,3
DO 10 J=1,3
NUMGP=(I-1)*3+J
GPX(NUMGP)=AR(I)*R
GPY(NUMGP)=AR(J)*R
10 CONTINUE
RETURN
END
CALL GSPT(GPX,GPY)
C
C DETERMINE GAUSS WEIGHTS
C
CALL GSWT(GWEI,GWE)
C
C ASSEMBLE AMATRX AND RHS
C
DO 300 K=1,9
C LOOP THROUGH GAUSS PTS
C=GPX(K)
E=GPY(K)
CALL DER(C,E,GPX,GPY,GWEI,PHI,PHIX,PHIY,PHIC,PHIE
1 ,DXDC,DXDE,DYDC,DYDE,AJACOB,COORDS,MCRD,NNODE)
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
C CHECK ON TEMPERATURE DEPENDENCE OF THERMAL CONDUCTIVITY
COND=CONDUC
DCDT=ZERO
DTDT=(T-TOLD)/DTIME
WE=GWEI(K)*AJACOB
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) + WE*(PHI(KI)*PHI(KJ)*RHO*
1 SPEC/DTIME + COND*(PHIX(KI)*PHIX(KJ) + PHIY(KI)*
2 PHIY(KJ)) + DCDT*PHI(KJ)*(PHIX(KI)*DTDX +
3 PHIY(KI)*DTDY))
END DO
END DO
300 CONTINUE
C
RETURN
END
C
C
SUBROUTINE GSWT(GWEI,GWE)
INCLUDE 'aba_param.inc'
DIMENSION GWEI(9),GWE(3)
C
PARAMETER(FIVE=5.D0,EIGHT=8.D0,NINE=9.D0)
C
C GWEI : GAUSS WEIGHT
C
GWE(1)=FIVE/NINE
GWE(2)=EIGHT/NINE
GWE(3)=FIVE/NINE
DO 10 I=1,3
DO 10 J=1,3
NUMGP=(I-1)*3+J
GWEI(NUMGP)=GWE(I)*GWE(J)
10 CONTINUE
RETURN
END
C
SUBROUTINE DER(C,E,GPX,GPY,GWEI,PHI,PHIX,PHIY,PHIC,PHIE,
1 DXDC,DXDE,DYDC,DYDE,AJACOB,COORDS,MCRD,NNODE)
INCLUDE 'aba_param.inc'
DIMENSION PHI(8),PHIX(8),PHIY(8),PHIC(8),PHIE(8),
1 COORDS(MCRD,NNODE)
C
PARAMETER(ZERO=0.D0,FOURTH=0.25D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0)
C
C INTERPOLATION FUNCTIONS
C
PHI(1) = FOURTH*(ONE-C)*(ONE-E)*(-C-E-ONE)
PHI(2) = FOURTH*(ONE+C)*(ONE-E)*(C-E-ONE)
PHI(3) = FOURTH*(ONE+C)*(ONE+E)*(C+E-ONE)
PHI(4) = FOURTH*(ONE-C)*(ONE+E)*(-C+E-ONE)
PHI(5) = HALF*(ONE-C*C)*(ONE-E)
PHI(6) = HALF*(ONE+C)*(ONE-E*E)
PHI(7) = HALF*(ONE-C*C)*(ONE+E)
PHI(8) = HALF*(ONE-C)*(ONE-E*E)
C
C DERIVATIVES WRT TO C
C
PHIC(1) = FOURTH*(ONE-E)*(TWO*C+E)
PHIC(2) = FOURTH*(ONE-E)*(TWO*C-E)
PHIC(3) = FOURTH*(ONE+E)*(TWO*C+E)
PHIC(4) = FOURTH*(ONE+E)*(TWO*C-E)
PHIC(5) = -C*(ONE-E)
PHIC(6) = HALF*(ONE-E*E)
PHIC(7) = -C*(ONE+E)
PHIC(8) = -HALF*(ONE-E*E)
C
C DERIVATIVES WRT TO E
C
PHIE(1) = FOURTH*(ONE-C)*(TWO*E+C)
PHIE(2) = FOURTH*(ONE+C)*(TWO*E-C)
PHIE(3) = FOURTH*(ONE+C)*(TWO*E+C)
PHIE(4) = FOURTH*(ONE-C)*(TWO*E-C)
PHIE(5) = -HALF*(ONE-C*C)
PHIE(6) = -E*(ONE+C)
PHIE(7) = HALF*(ONE-C*C)
PHIE(8) = -E*(ONE-C)
DXDC=ZERO
DXDE=ZERO
DYDC=ZERO
DYDE=ZERO
DO 3 I=1,8
DXDC=DXDC+COORDS(1,I)*PHIC(I)
DXDE=DXDE+COORDS(1,I)*PHIE(I)
DYDC=DYDC+COORDS(2,I)*PHIC(I)
DYDE=DYDE+COORDS(2,I)*PHIE(I)
3 CONTINUE
C
C CALCULATION OF JACOBIAN
C
AJACOB=(DXDC*DYDE-DXDE*DYDC)
C
C DERIVATIVES WRT TO X AND Y
C
DO 5 I=1,8
PHIX(I)=(PHIC(I)*DYDE-PHIE(I)*DYDC)/AJACOB
PHIY(I)=(PHIE(I)*DXDC-PHIC(I)*DXDE)/AJACOB
5 CONTINUE
RETURN
END