按书上码的，这几个错误感觉莫名其妙，求救

chaunceyyou · 发表于 2018-5-16 18:30:09

[Fortran] 纯文本查看 复制代码

PROGRAM PFSAP
!ANALYSIS PROGRAM FOR PLANE FRAME
INTEGER NO,NJ,N,NE,NM,NPJ,NPF,I,J,IE,IP,KK,I1
REAL K(200,200),KE(6,6),AKE(6,6),X(100),Y(100),AL(100),EAI(3,100),PJ(100),PF(2,100),R(6,6),P(100),FF(6),FE(6),ADE(6),DE(6),RT(6,6),AFE(6),F(3),D(100)
INTEGER JE(2,100),JN(3,100),JPJ(100),JPF(2,100),M(6),JEAI(100)
CHARACTER *80 TITLE
1 OPEN (6,FILE='PFSAP.IN')
OPEN (8,FILE='PFSAP.OUT')
READ(6,'(I3)')NO
IF(NO.EQ.0) STOP
WRITE(8,"('(NO='I3,')')")NO
CALL PUTIN(NJ,N,NE,NM,NPJ,NPF,JN,X,Y,JE,JEAI,EAI,JPJ,PJ,JPF,PF)
DO I=1,N
   P(I)=0.0
   DO J=1,N
      K(I,J)=0
   END DO
END DO
DO IE=1,NE
   CALL MKE(KE,IE,JE,JEAI,EAI,X,Y,AL)
   CALL MR(R,IE,JE,X,Y)
   CALL MAKE(KE,R,AKE)
   CALL CALM(M,IE,JN,JE)
   CALL MK(K,AKE,M)
END DO
DO IP=1,NPF
   CALL MR(R,JPF(1,IP),JE,X,Y)
   CALL TRAN(R,RT)
   CALL PE(FE,IP,JPF,PF,AL)
   CALL MULV6(RT,FE,AFE)
   CALL CALM(M,JPF(1,IP),JN,JE)
   CALL MF(P,AFE,M)
END DO
DO I=1,NPJ
   P(JPJ(I))=P(JPJ(I))+PJ(I)
END DO
END
CALL SLOV(K,P,D,N)
WRITE(8,*) "/10X,5('* *'),'RESULTS OF CALCULATION',5('* *')"
WRITE(8,40)
40 FORMAT(/5X,'NO.N',4X,'X-DISPLACEMENT',2X,'Y-DISPLEMENT',3X,'ANG.ROT.(RAD)')
DO KK=1,NJ
   DO I=1,3
      F(I)=0.0
      I1=JN(I,KK)
      IF(I1.GT.0) F(I)=D(I1)
   END DO
WRITE(8,70)KK,F(1),F(2),F(3)
70 FORMAT(I8,2X,3G16.5)
END DO
WRITE(8,80)
80 FORMAT(/'NO.E',5X,'N(1)',8X,'Q(1)',8X,'M(1)',8X,'N(2)',8X,'Q(2)',8X,'M(2)')
DO IE=1,NE
   CALL MADE(IE,JN,JE,D,ADE)
   CALL MKE(KE,IE,JE,KEAI,EAI,X,Y,AL)
   CALL MR(R,IE,JE,X,Y)
   CALL MULV6(R,ADE,DE)
   CALL MULV6(KE,DE,FF)
     DO IP=1,NPF
        IF(JPF(1,IP).EQ.IE)THEN
          CALL PE(FE,IP,JPF,PF,AL)
          DO I=1,6
             FF(I)=FF(I)-FE(I)
          END DO
        END IF
     END DO
    WRITE(8,110)IE,(FF(I),I=1,6)
110    FORMAT(I5,2X,6G12.5)
END DO
GOTO 1
END PROGRAM PFSAP
SUBROUTINE PUTIN(NJ,N,NE,NM,NPJ,NPF,JN,X,Y,JE,JEAI,EAI,JPJ,PJ,JPF,PF)
REAL X(100),Y(100),EAI(3,100),PJ(100),PF(2,100)
INTEGER JE(2,100),JN(3,100),JPJ(100),JPF(2,100),JEAI(100)
CHARACTER*80 TITLE
READ(6,*)TITLE
WRITE(8,*)TITLE
READ(6,*)NJ,N,NE,NM,NPJ,NPF
WRITE(8,3)NJ,N,NE,NM,NPJ,NPF
3 FORMAT(/'NJ='I2,5X,'N='I2,5X,'NE='I2,5X,'NM='I2,5X,'NPJ='I2,5X,'NPF='I2)
WRITE(8,5)
5 FORMAT(/4X,'NO.(1) (2) (3)',10X,'X',8X,'Y')
READ(6,10)((JN(J,I),J=1,3),X(I),Y(I),I=1,NJ)
10 FORMAT(2(3I5,2G16.4))
DO I=1,NJ
   WRITE(8,11)I,JN(1,I),JN(2,I),JN(3,I),X(I),Y(I)
11 FORMAT(2X,I2,3I6,4X,2F10.3)
END DO
WRITE(8,30)
30 FORMAT(/10X,'ELEMENT NO. NODE-1 NODE-2 MATERIALS')
READ(6,40)(JE(1,I),JE(2,I),JEAI(I),I=1,NE)
40 FORMAT(5(3I5))
DO I=1,NE
   WRITE(8,'(14X,I2,3(7X,I3))')I,JE(1,I),JE(2,I),JEAI(I)
END DO
READ(6,*)((EAI(I,J),I=1,3),J=1,NM)
WRITE(8,60)(J,(EAI(I,J),I=1,3),J=1,NM)
60 FORMAT(/3X,'NO.MAT',6X,'ELASTIK MOUDULUS',8X,'AREA',5X,'MOMENT OF INERTIA'/(I6,9X,3G16.6))
IF(NPJ.NE.0)THEN
  WRITE(8,*) "/20X,'NODEL LOADS'"
  WRITE(8,*) "/16X,'NO.DISP.VALUE'"
  READ(6,70)(JPJ(I),PJ(I),I=1,NPJ)
70 FORMAT(5(I5,G16.4))
  DO I=1,NPJ
   WRITE(8,'(14X,I7,F16.3)')JPJ(I),PJ(I)
  END DO
ELSE
END IF
IF(NPF.NE.0) THEN
  WRITE(8,*) "/20X,'NON-NODEL LOADS'"
  WRITE(8,*) "11X,'NO.E NO.LOAD.MODEL',8X,'A',9X,'C'"
  READ(6,100)(JPF(1,I),JPF(2,I),PF(1,I),PF(2,I),I=1,NPF)
100 FORMAT(2(2I5,2G16.4))
  DO I=1,NPF
     WRITE(8,120)(JPF(J,I),J=1,2),PF(1,I),PF(2,I)
120 FORMAT(6X,2I8,10X,2F10.3)
  END DO
ELSE 
END IF
RETURN
END
SUBROUTINE MKE(KE,IE,JE,JEAI,EAI,X,Y,AL)
INTEGER I,J,II,JJ,MT
REAL L,A1,A2,A3,A4
REAL KE(6,6),X(100),Y(100),EAI(3,100),AL(100)
II=JE(1,IE)
JJ=JE(2,IE)
MT=JEAI(IE)
L=SQRT((X(JJ)-X(II))**2+(Y(JJ)-Y(II))**2)
AL(IE)=L
A1=EAI(1,MT)*EAI(2,MT)/L
A2=EAI(1,MT)*EAI(3,MT)/L**3
A3=EAI(I,MT)*EAI(3,MT)/L**2
A4=EAI(1,MT)*EAI(3,MT)/L
KE(1,1)=A1
KE(1,4)=-A1
KE(2,2)=12*A2
KE(2,3)=6*A3
KE(2,5)=-12*A2
KE(2,6)=6*A3
KE(3,3)=4*A4
KE(3,5)=-6*A3
KE(3,6)=2*A4
KE(4,4)=A1
KE(5,5)=12*A2
KE(6,6)=4*A4
DO I=1,6
   DO J=I,6
      KE(J,I)=KE(I,J)
   END DO
END DO
RETURN
END
SUBROUTINE MR(R,IE,JE,X,Y)
INTEGER I,J
REAL L,CX,CY
REAL R(6,6),X(100),Y(100)
I=JE(1,IE)
J=JE(2,IE)
L=SQRT(X(J)-X(I))**2+(Y(J)-Y(I))**2
CX=(X(J)-X(I))/L
CY=(Y(J)-Y(I))/L
DO J=1,6
   DO I=1,6
      R(I,J)=0.0
   END DO
END DO
DO I=1,4,3
   R(I,I)=CX
   R(I,I+1)=CY
   R(I+1,I)=-CY
   R(I+1,I+1)=CX
   R(I+2,I+2)=1.0
END DO
RETURN 
END
SUBROUTINE MAKE(KE,R,AKE)
REAL KE(6,6),R(6,6),RT(6,6),TMP(6,6),AKE(6,6)
CALL TRAN(R,RT)
CALL MULV(RT,KE,TMP)
CALL MULV(TMP,R,AKE)
RETURN
END
SUBROUTINE CALM(M,IE,JN,JE)
INTEGER I,IE
INTEGER M(6),JN(3,100),JE(2,100)
DO I=1,3
   M(I)=JN(I,JE(1,IE))
   M(I+3)=JN(I,JE(2,IE))
END DO
RETURN
END
SUBROUTINE MK(K,AKE,M)
INTEGER I,J
REAL K(200,200),AKE(6,6)
INTEGER M(6)
DO I=1,6
   DO J=1,6
      IF(M(I).NE.0.AND.M(J).NE.0)
        K(M(I),M(J))=K(M(I),M(J))+AKE(I,J)
   END DO
END DO
RETURN
END
SUBROUTINE PE(FE,IP,JPF,PF,AL)
INTEGER I,IND
INTEGER JPF(2,100)
REAL L,A,C
REAL FE(6),PF(2,100),AL(100)
A=PF(1,IP)
C=PF(2,IP)
L=AL(JPF(1,IP))
IND=JPF(2,IP)
DO I=1,6
   FE(I)=0.0
END DO
SELECT CASE(IND)
  CASE(1)
   FE(2)=(7.0*A/20.0+3.0*C/20.0)*L
   FE(3)=(A/20.0+C/30.0)*L**2
   FE(5)=(3.0*A/20.0+7.0*C/20.0)*L
   FE(6)=-(A/30.0+C/20.0)*L**2
   RETURN
  CASE(2)
   FE(5)=A*C**3*(2*L-C)/(2*L**3)
   FE(6)=-A*C**3*(4.0*L-3.0*C)/(12.0*L**2)
   FE(2)=A*C-FE(5)
   FE(3)=A*C**2*(6.0*L**2-8.0*C*L+3.0*C**2)/(12.0*L**2)
   RETURN
  CASE(3)
   FE(2)=A*(L-C)**2*(L+2*C)/L**3
   FE(3)=A*C*(L-C)**2/L**2
   FE(5)=A-FE(2)
   FE(6)=-A*C**2*(L-C)/L**2
   RETURN
  CASE(4)
   FE(2)=-6.0*A*C*(L-C)/L**3
   FE(3)=A*(L-C)*(L-3.0*C)/L**2
   FE(5)=-FE(2)
   FE(6)=A*C*(3.0*C-2.0*L)/L**2
   RETURN
  CASE(5)
   FE(1)=A*(1-C/L)
   FE(4)=A*C/L
  CASE(6)
   FE(1)=C*L/2
   FE(4)=FE(1)
 END SELECT
END
SUBROUTINE MULV6(A,B,C)
INTEGER I,J
REAL C(6),A(6,6),B(6)
DO I=1,6
   C(I)=0.0
   DO J=1,6
      C(I)=C(I)+A(I,J)*B(J)
   END DO
END DO
RETURN
END
SUBROUTINE MF(P,AFE,M)
INTEGER I
INTEGER M(6)
REAL P(100),AFE(6)
DO I=1,6
   IF(M(I).NE.0)P(M(I))=AFE(I)+P(M(I))
END DO
RETURN
END
SUBROUTINE SLOV(AK,P,D,N)
INTEGER I,J,K,N
REAL AK(200,200),P(100),D(100)
DO I=1,100
   D(I)=P(I)
END DO
DO K=1,N-1
   DO I=K+1,N
      C=-AK(K,I)/AK(K,K)
      DO J=I,N
         AK(I,J)=AK(I,J)+C*AK(K,J)
      END DO
      D(I)=D(I)+C*D(K)
   END DO
END DO
D(N)=D(N)/AK(N,N)
DO I=N-1,1,-1
   DO J=I+1,N
      D(I)=D(I)-AK(I,J)*D(J)
   END DO
   D(I)=D(I)/AK(I,I)
END DO
RETURN
END
SUBROUTINE MADE
INTEGER I
REAL ADE(6),D(100)
INTEGER IE,JN(3,100),JE(2,100)
DO I=1,6
   ADE(I)=0
END DO
DO I=1,3
   IF(JN(I,JE(1,IE)).NE.0) ADE(I)=D(JN(I,JE(1,IE)))
   IF(JN(I,JE(2,IE)).NE.0) ADE(I+3)=D(JN(I,JE(2,IE)))
END DO
RETURN
END
SUBROUTINE TRAN(R,RT)
INTEGER I,J
REAL R(6,6),RT(6,6)
DO I=1,6
   DO J=1,6
      RT(I,J)=R(J,I)
   END DO
END DO
RETURN
END
SUBROUTINE MULV(A,B,C)
INTEGER I,J,K
REAL A(6,6),B(6,6),C(6,6)
DO I=1,6
   DO J=1,6
      C(I,J)=0.0
      DO K=1,6
         C(I,J)=C(I,J)+A(I,K)*B(K,J) 
      END DO
   END DO
END DO
RETURN
END

chaunceyyou · 发表于 2018-5-16 18:46:47

已经解决，谢谢

[求助] 按书上码的，这几个错误感觉莫名其妙，求救