平面四边形四节点等参单元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)=

enddo

CALL SK0(SK,MEL,COOR,JR,MA,AE)

do I=1,N

R(I)=

enddo

pause 'aaa'

stop

READ(4,*)NCP,NBE,iz

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

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

IF CONCR(NCP,R,JR)

IF CALL BODYR(NBE,R,MEL,COOR,JR,AE)

IF 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,)) 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 GO TO 80

IF L=NNI

80 CONTINUE

DO 85 M=1,2*4

JP=NN(M)

IF GO TO 85

JPL=JP-L+1

IF MA(JP)=JPL

85 CONTINUE

90 CONTINUE

MX=0

MA(1)=1

DO 10 I=2,N

IF(MA(I). 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 **********************************************