C     PROGRAM 3. TR2D.FOR
C     PLANE TRUSS 
      DIMENSION NP(100),NM(100),S(100) 
      DOUBLE PRECISION R(100),P(100),C(100,100),UVEC(2)
     1,C1,D1,F1,F2,FAC,PSAVE(100)
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 29.0D06
      SIGA=1.
      SMALL=1.E-10
100   READ(50,150)NB,NN,NS,nbsup 
150   FORMAT (4I5)
      WRITE(60,1)NB,NN,NS,nbsup
    1 FORMAT(I5,'  NO. MEMBERS'/I5,'  NO. NODES'/I5,
     1'  NO.SUPPORTS'/i5,'  NO.Support BARS'//)
      READ(50,156)(R(2*K-1),R(2*K),PSAVE(2*K-1),
     1 PSAVE(2*K),K=1,NN)
  156 FORMAT (8X,4F11.6) 
      WRITE(60,157)(K,R(2*K-1),R(2*K),PSAVE(2*K-1),
     1 PSAVE(2*K),K=1,NN)
157   FORMAT (1H1,16X,11HCOORDINATES,28X,5HLOADS/
     1 14X,1HX,17X,1HY,16X,2HPX,16X,2HPY//(I4,4D18.8))
      NNN = NN - NS 
      N=2*NNN
      nb1=nb-nbsup
C
C     SET UP SYSTEM MATRIX
C
      NIT=20
      DO 9981 ITER=1,NIT
      VOLUME=0.
      DO 30 I = 1,N
      P(I)=PSAVE(I)
      DO 30 J = 1,N 
   30 C(I,J) = 0. 
      WRITE(60,159) 
      DO 999 L=1,NB
      IF(ITER.EQ.1)
     1   READ(50,151)NP(L),NM(L),S(L) 
        WRITE(60,160)L,NP(L),NM(L),S(L) 
151     FORMAT (2I5,8X,E10.6) 
160     FORMAT (3I10,E20.8) 
        K = 2*NP(L) 
        M = 2*NM(L) 
        CALL UNITV(K,M,C1,UVEC,R)
        CALL INSERT(C,K,M,UVEC,MAXC,N,E,S(L),C1)
 999  CONTINUE
C
C     SOLVE FOR JOINT DISPLACEMENTS
C
      M = N - 1 
      DO 17 I = 1,M 
        L = I + 1 
        DO 17 J = L,N 
          IF(C(J,I)) 19,17,19 
   19       DO 18 K = L,N 
   18         C(J,K) = C(J,K) - C(I,K)*C(J,I)/C(I,I) 
        P(J) = P(J) - P(I)*C(J,I)/C(I,I) 
   17 CONTINUE
      P(N) = P(N)/C(N,N) 
      DO 20 I = 1,M 
        K = N - I 
        L = K + 1 
        DO 21 J = L,N 
   21     P(K) = P(K) - P(J)*C(K,J) 
        P(K) = P(K)/C(K,K) 
   20 CONTINUE 
      WRITE(60,161)(I,P(2*I-1),P(2*I),I=1,NN)
  161 FORMAT (1H1,13HDISPLACEMENTS/20X,1HX,19X,1HY//
     1//(I10,2D20.8))
      WRITE(60,162) 
  162 FORMAT(1H1,3X,6HMEMBER,9X,2HDL,17X,5HFORCE,
     1 14X,6HSTRESS//)
C
C     COMPUTE MEMBER FORCES AND DISPLACEMENTS
C
      DO 998 I=1,NB
        K = 2*NP(I) 
        M = 2*NM(I) 
        CALL UNITV(K,M,C1,UVEC,R)
        K1=K
        D1=0.
        FAC=1.
        DO 997 J=1,2
          IF(K1.GT.N) GO TO 996
          D1=D1+FAC*(P(K1-1)*UVEC(1)+P(K1)*UVEC(2))
 996      FAC=-1.
          K1=M
 997    CONTINUE
        F1=D1*E*S(I)/C1 
        F2=F1/S(I)
        if(i.gt.nb1)go to 9982
        VOLUME=VOLUME+S(I)*C1
        S(I)=ABS(F1)/SIGA
        IF(S(I).EQ.0.) S(I)=SMALL
 9982 WRITE(60,1000) I,D1,F1,F2 
  998 CONTINUE
 9981 WRITE(60,61) ITER, VOLUME
  61  FORMAT('**** ITER = ',I5,'    VOLUME = ',E20.8)
      STOP
 1000 FORMAT (I10,3D20.8) 
  159 FORMAT (1H1,3X,6HMEMBER,5X,5H+ END,5X,5H- END,6X,4HAREA//) 
      END 
C 
      SUBROUTINE UNITV(K,M,C1,UVEC,R) 
      DOUBLE PRECISION R(1),C1,UVEC(2)
      C1=0. 
      DO 1 I=1,2
        UVEC(I)=R(K+I-2)-R(M+I-2)
    1 C1=C1+UVEC(I)**2 
      C1=DSQRT(C1) 
      DO 2 I=1,2
    2 UVEC(I)=UVEC(I)/C1 
      RETURN 
      END 
C
      SUBROUTINE INSERT(C,K,M,UVEC,MAXC,N,E,S,C1)
      DOUBLE PRECISION C(MAXC,MAXC),UVEC(2),C1
      K1=K
      DO 1 I=1,2
        IF(K1.GT.N) GO TO 1
        M1=K
        DO 2 J=1,2
          IF(M1.GT.N) GO TO 2
          FAC=1.
          IF(I.NE.J) FAC=-1.
          DO 3 L=1,2
            I1=K1-2+L
          DO 3 L1=1,2
            J1=M1-2+L1
    3     C(I1,J1)=C(I1,J1)+UVEC(L)*UVEC(L1)*S*E*FAC/C1
    2   M1=M
    1 K1=M
      RETURN
      END
