a15.for

ADINA84有限元编程学习的好例子

      SUBROUTINE ELT3D3
C
C
C
C
C
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1            ,NDOFDM,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIMEL/ N101,N102,N103,N104,N105,N106,N107,N108,N109,N110,
     1               N111,N112,N113,N114,N120,N121,N122,N123,N124,N125
      COMMON /DPR/ ITWO
      COMMON /MTMD3D/ D(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS,ISVE
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON A(1)
C
      REAL A
C
      DIMENSION IA(1)
C
      EQUIVALENCE (NPAR(10),NINT),(NPAR(7),MXNODS),(A(1),IA(1))
      EQUIVALENCE (NPAR(17),NCON)
C
C
C
C
C
      NN=N112+(NEL-1)*MXNODS
      IF(IND.NE.0) GO TO 100
C
C
      CALL ITHEL3(A(NN))
      GO TO 200
C
C
  100 MATP=IA(N107+NEL-1)
C
C
      NM=N111+(MATP-1)*NCON*ITWO
C
C
      ND9DIM=MXNODS-8
      LL=N108+(NEL-1)*ND9DIM
C
C
      CALL THEL3(A(NM),A(NN),A(N6B + ITWO),A(LL))
C
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE ITHEL3(IWA)
C
C
C
C
C
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      COMMON /DPR/ ITWO
      COMMON /EM3D/ NOD(27),NODM(27),NOD9M(19)
C
      DIMENSION IWA(*)
C
C
C
      II=0
      DO 15 K=1,27
      IF(NODM(K).EQ.0) GO TO 15
      II=II+1
      IWA(II)=NODM(K)
   15 CONTINUE
C
      RETURN
C
      END
      SUBROUTINE THEL3(PROP,NDS,TEMPV2,NOD9M)
C
C
C
C
C
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      COMMON /SOLPM3/ TREF,XINTP,XCON1,XCON2,XPARM1,XPARM2,TOLIL,TOLPC,
     1               TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TCHK,CRPCON(8),DTMN,
     2               SUBDD,RNGL,RNGU,DTT,TOL7,
     3               KCRP,NITE,NALG,IINTP,NPTS,ITCHK
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /TEMPRT/ TEMP1,TEMP2,ITEMPR,ITP96,N6A,N6B
      COMMON /MTMD3D/ C(6,6),STRESS(6),STRAIN(6),IPT,NEL,IPS,ISVE
      COMMON /GAUSS/ XG(6,6),WGT(6,6),EVAL2(9,2),EVAL3(27,3),E1,E2,E3
      COMMON /THREED/ DE,IELD,IELX,IEL,NPT,IDW,NND9,ISOCOR
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,IBPORT,IFPORT,JDC,JVC,JAC
C
      DIMENSION PROP2(3),PROP(16,*),EPST(6),NDS(*),NOD9M(*),TEMPV2(*),
     1          H(27),XDM1(3,27),XDM2(3,3),XDM3(3,1)
C
      EQUIVALENCE (NPAR(3),INDNL)
C
C
C
      IF(IPT.GT.1) GO TO 5
      TOLMT=1.D-2
      NPTS=INT(PROP(1,5))
      TREF=PROP(2,5)
      IINTP=1
C
      TOLL=TOLMT*ABS(PROP(1,1))
      IF (TOLL.EQ.0.D0) TOLL=TOLMT
      TOLU=TOLMT*ABS(PROP(NPTS,1))
      IF (TOLU.EQ.0.D0) TOLU=TOLMT
C
      RNGL=PROP(1,1) - TOLL
      RNGU=PROP(NPTS,1) + TOLU
C
C
    5 CALL FUNCT(E1,E2,E3,H,XDM1,NOD9M,XDM2,XDUM,XDM3,IINTP)
      TEMP2=0.D0
      DO 10 K=1,IELD
      KK=NDS(K)
   10 TEMP2=TEMP2+H(K)*TEMPV2(KK)
C
C
      IF(TEMP2.GE.RNGL) GO TO 35
      write(66,2008)
      STOP
C
   35 L=0
      DO 40 K=2,NPTS
      L=L+1
      DUM=PROP(K,1)
      IF(K.EQ.NPTS) DUM=RNGU
      IF(TEMP2.GT.DUM) GO TO 40
      GO TO 45
   40 CONTINUE
      write(66,2008)
      STOP
C
   45 RATIO=(TEMP2-PROP(L,1))/(PROP(L+1,1)-PROP(L,1))
C
C
      IF (RATIO.GT.1.D0) RATIO=1.D0
      IF (RATIO.LT.0.D0) RATIO=0.D0
C
      DO 60 M=2,4
   60 PROP2(M-1)=PROP(L,M)+RATIO*(PROP(L+1,M)-PROP(L,M))
C
C
      YM2=PROP2(1)
      PV2=PROP2(2)
      A2=YM2/(1.+PV2)
      C2=0.5*A2
      A2=A2/(1.-2.*PV2)
      B2=A2*PV2
      A2=A2*(1.-PV2)
C
C
   80 EPST(1)=PROP2(3)*(TEMP2-TREF)
      EPST(2)=EPST(1)
      EPST(3)=EPST(1)
      EPST(4)=0.D0
      EPST(5)=0.D0
      EPST(6)=0.D0
C
C
      STRESS(1)=A2*(STRAIN(1)-EPST(1))+B2*(STRAIN(2)+STRAIN(3)-
     1          EPST(2)-EPST(3))
      STRESS(2)=A2*(STRAIN(2)-EPST(2))+B2*(STRAIN(1)+STRAIN(3)
     1          -EPST(1)-EPST(3))
      STRESS(3)=A2*(STRAIN(3)-EPST(3))+B2*(STRAIN(1)+STRAIN(2)
     1          -EPST(1)-EPST(2))
      STRESS(4)=C2*STRAIN(4)
      STRESS(5)=C2*STRAIN(5)
      STRESS(6)=C2*STRAIN(6)
C
C
   90 IF(KPRI.EQ.0) GO TO 190
C
C
      IF(ICOUNT.EQ.3) RETURN
C
C           END OF STEP
C
      DO 115 I=1,6
      DO 115 J=1,6
  115 C(I,J)=0.D0
C
      C(1,1)=A2
      C(1,2)=B2
      C(1,3)=B2
      C(2,1)=B2
      C(2,2)=A2
      C(2,3)=B2
      C(3,1)=B2
      C(3,2)=B2
      C(3,3)=A2
      C(4,4)=C2
      C(5,5)=C2
      C(6,6)=C2
      RETURN
C
C
C
  190 IF(INDNL.NE.2) GO TO 200
C
C
      CALL CAUCH3
C
  200 IF (IPRI.NE.0 .OR. IPS.EQ.0) GO TO 300
      IF (NG.NE.NGLAST) GO TO 202
      IF(NEL.GT.NELAST) GO TO 206
      IF(IPT-1) 210,208,210
C
  202 NGLAST=NG
  208 write(66,2002)
  206 NELAST=NEL
      write(66,2004) NEL
  210 write(66,2005) IPT,(STRESS(J),J=1,6),TEMP2
C
C
  300 IF (JNPORT.EQ.0 .OR. KPLOTE.NE.0) GO TO 310
      IF (ISVE.EQ.0) GO TO 310
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) 'OUTPUT-3',NEL,IPT,(STRESS(I),I=1,6),
     2                       (STRAIN(I),I=1,6),TEMP2
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9000) 'OUTPUT-3',NEL,IPT,(STRESS(I),I=1,6),
     2                       (STRAIN(I),I=1,6),TEMP2
C
 9000 FORMAT ( A,/,2I10,/,(4E20.13) )
C
C
  310 RETURN
 2002 FORMAT (1X,7HELEMENT,14X,9HSTRESS-XX,5X,9HSTRESS-YY,
     1        5X,9HSTRESS-ZZ,5X,9HSTRESS-XY,5X,9HSTRESS-XZ,5X,
     2        9HSTRESS-YZ,3X,11HTEMPERATURE,/,1X,7HNUM/IPT,/ 1X)
 2004 FORMAT(I4,/)
 2005 FORMAT (5X,I3,9X,7(E14.6))
 2008 FORMAT(92H    ERROR   TEMPERATURE OUTSIDE RANGE OF MATERIAL PROPER
     1TY TEMPERATURES   (SUBROUTINE THEL3))
 2009 FORMAT(14X,14HTEMPERATURE = ,E14.6,/)
C
C
C*FILE END
      END