平面四边形四节点等参单元Fortran源程序

C ************************************************

C * FINITE ELEMENT PROGRAM * C * FOR Two DIMENSIONAL ELASticity PROBLEM * C * WITH 4 NODE * C ************************************************ PROGRAM ELASTICITY character*32 dat,cch

DIMENSION SK(80000),COOR(2,300),AE(4,11),MEL(5,200), & WG(4),JR(2,300),MA(600),R(600),iew(30),STRE(3,200) COMMON /CMN1/ NP,NE,NM,NR COMMON /CMN2/ N,MX,NH

COMMON /CMN3/ RF(8),SKE(8,8),NN(8)

WRITE(*,*)'PLEASE ENTER INPUT FILE NAME' READ(*,'(A)')DAT

OPEN(4,FILE=dat,STATUS='OLD')

OPEN(7,FILE='OUT',STATUS='UNKNOWN') READ(4,*)NP,NE,NM,NR

WRITE(7,'(A,I6)')'NUMBER OF NODE---------------------NP=',np WRITE(7,'(A,I6)')'NUMBER OF ELEMENT------------------NE=',ne WRITE(7,'(A,I6)')'NUMBER OF MATERIAL-----------------NM=',nm WRITE(7,'(A,I6)')'NUMBER OF surporting---------------NC=',Nr CALL INPUT (JR,COOR,AE,MEL) CALL CBAND (MA,JR,MEL) DO I=1,NH SK(I)=0.0 enddo

CALL SK0(SK,MEL,COOR,JR,MA,AE) do I=1,N R(I)=0.0 enddo pause 'aaa' stop

READ(4,*)NCP,NBE,iz

WRITE(*,'(5i8)')NCP,NBE,iz WRITE(7,'(5i8)')NCP,NBE,iz

IF(NCP.GT.0)CALL CONCR(NCP,R,JR)

IF(NBE.GT.0) CALL BODYR(NBE,R,MEL,COOR,JR,AE) IF(iz.GT.0)then do jj=1,iz

READ (4,*)Js,nse,(WG(I),I=1,4) read(4,*)(iew(m),m=1,nse)

CALL FACER(iew,NSE,R,MEL,COOR,JR,WG) enddo endif

CALL DECOP (SK,MA) CALL FOBA (SK,MA,R) CALL OUTDISP(NP,R,JR)

CALL STRESS (COOR,MEL,JR,AE,R,STRE)

WRITE(7,'(A)')' PROGRAM SAFF HAS BEEN ENDED' WRITE(*,'(A)')' PROGRAM SAFF HAS BEEN ENDED' STOP c RETURN END

C ********************************************* SUBROUTINE INPUT (JR,COOR,AE,MEL)

DIMENSION JR(2,*),COOR(2,*),AE(4,*),MEL(5,*) COMMON /CMN1/ NP,NE,NM,NR COMMON /CMN2/ N,MX,NH DO 70 I=1,NP READ(4,*) IP,X,Y COOR(1,IP)=X COOR(2,IP)=Y 70 CONTINUE DO 11 J=1,NE

READ(4,*)NEE,NME,(MEL(I,NEE),I=1,4) MEL(5,NEE)=NME 11 CONTINUE DO 10 I=1,NP DO 10 J=1,2 10 JR(J,I)=1

DO 20 I=1,NR

READ(4,*) IP,IX,IY JR(1,IP)=IX JR(2,IP)=IY 20 CONTINUE N=0

DO 30 I=1,NP DO 30 J=1,2

IF (JR(J,I)) 30,30,25 25 N=N+1 JR(J,I)=N 30 CONTINUE DO 55 J=1,NM

READ (4,*)JJ,(AE(I,JJ),I=1,4) WRITE(*,910) JJ,(AE(I,JJ),I=1,4) 55 CONTINUE

910 FORMAT (/20X,'MATERIAL PROPERTIES'/(3X,I5,4(1x,E8.3))) RETURN

END

C ********************************************** SUBROUTINE CBAND (MA,JR,MEL)

DIMENSION MA(*),JR(2,*),MEL(5,*),NN(8) COMMON /CMN1/ NP,NE,NM,NR COMMON /CMN2/ N,MX,NH DO 65 I=1,N 65 MA(I)=0

DO 90 IE=1,NE DO 75 K=1,4 IEK=MEL(K,IE) DO 95 M=1,2 JJ=2*(K-1)+M NN(JJ)=JR(M,IEK) 95 CONTINUE 75 CONTINUE L=N

DO 80 I=1,2*4 NNI=NN(I)

IF(NNI.EQ.0) GO TO 80 IF(NNI.LT.L) L=NNI 80 CONTINUE DO 85 M=1,2*4 JP=NN(M)

IF(JP.EQ.0) GO TO 85 JPL=JP-L+1

IF(JPL.GT.MA(JP)) MA(JP)=JPL 85 CONTINUE 90 CONTINUE MX=0 MA(1)=1 DO 10 I=2,N

IF(MA(I).GT.MX) MX=MA(I) MA(I)=MA(I)+MA(I-1) 10 CONTINUE NH=MA(N)

WRITE(7,'(A,I8)')'TOTAL DEGREES OF FREEDOM-----------N= ',N WRITE(7,'(A,I8)')'MAX-SEMI-BANDWIDTH-----------------MX=',MX WRITE(7,'(A,I8)')'TOTAL-STORAGE----------------------NH=',NH 500 FORMAT (/5X,'FREEDOM N='

*,I5,3X,'SEMI-BANDWI. MX=',I5,3X, * 'STORAGE NH=',I7) RETURN END

C ********************************************** SUBROUTINE SK0(SK,MEL,COOR,JR,MA,AE)

DIMENSION SK(*),MEL(5,*),COOR(2,*),JR(2,*),MA(*), * AE(4,*),XYZ(2,4),iven(4) COMMON /CMN1/ NP,NE,NM,NR COMMON /CMN2/ N,MX,NH

COMMON /CMN3/ RF(8),SKE(8,8),NN(8) COMMON /CMN4/ NEE,NME COMMON /GAUSS/ RSTG(3),H(3) H(1)=0.5555555555555560 H(2)=0.8888888888888890 H(3)=H(1)

RSTG(1)=-0.7745966692414830 RSTG(2)=0.00

RSTG(3)=-RSTG(1) DO 10 IE=1,NE NEE=IE

NME=MEL(5,IE) DO 75 K=1,4 IEK=MEL(K,IE) iven(k)=IEK DO 95 M=1,2 JJ=2*(K-1)+M NN(JJ)=JR(M,IEK)

95 XYZ(M,K)=COOR(M,IEK) 75 CONTINUE

CALL STIF(XYZ,AE,iven) DO 60 I=1,8 DO 60 J=1,8 II=NN(I) JJ=NN(J)

IF ((JJ.EQ.0).OR.(II.LT.JJ)) GO TO 60 JN=MA(II)-(II-JJ)

SK(JN)=SK(JN)+SKE(I,J) 60 CONTINUE 70 CONTINUE

write(7,1111) ((ske(i,j),j=1,8),i=1,8) 1111 format(2x,8f12.2) 10 CONTINUE RETURN END

C ********************************************* SUBROUTINE STIF(XYZ,AE,iven)

DIMENSION AE(4,*),DNX(2,4),XYZ(2,*),iven(*),

* RJAC(2,2)

COMMON /CMN1/ NP,NE,NM,NR COMMON /CMN2/ N,MX,NH

COMMON /CMN3/ RF(8),SKE(8,8),NN(8) COMMON /CMN4/ NEE,NME COMMON /GAUSS/ RSTG(3),H(3) DO 40 I=1,8 RF(I)=0.00 DO 30 J=1,8 SKE(I,J)=0.00 30 CONTINUE 40 CONTINUE E=AE(1,NME) U=AE(2,NME)

GAMA=AE(3,NME)

D1=E*(1.00-U)/((1.00+U)*(1.00-2.00*U)) D2=E*U/((1.00+U)*(1.00-2.00*U)) D3=E*0.50/(1.00+U) DO 120 I=1,4 II=2*(I-1) I1=II+1 I2=II+2

DO 115 J=1,4 JJ=2*(J-1) J1=JJ+1 J2=JJ+2 DXX=0 DXY=0 DYX=0 DYY=0

DO 99 IS=1,3 S=RSTG(IS) SH=H(IS) DO 98 IR=1,3 R=RSTG(IR) RH=H(IR)

CALL FDNX (XYZ,DNX,DET,R,S,RJAC,iven,NEE) DNIX=DNX(1,I) DNIY=DNX(2,I) DNJX=DNX(1,J) DNJY=DNX(2,J)

DXX=DXX+DNIX*DNJX*DET*RH*SH DXY=DXY+DNIX*DNJY*DET*RH*SH DYX=DYX+DNIY*DNJX*DET*RH*SH

本文来源：https://www.bwwdw.com/article/nsyd.html