c     dynamic.for
C     PLANE TRUSS DYNAMICS
      use imsl
      DIMENSION NP(100),NM(100),S(100)
     1 ,AMASS(50,50)
      double precision r(100)
      common NP,NM,S,R,amass
      COMMON /DAT/E,NB,NN,NS,N,NNN,MAXC
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 29.0D06
100   READ(50,150)NB,NN,NS 
150   FORMAT (3(I4,3X)) 
      WRITE(60,1)NB,NN,NS
    1 FORMAT(I5,'  NO. MEMBERS'/I5,'  NO. NODES'/I5,
     1'  NO.SUPPORTS'//)
      READ(50,156)(R(2*K-1),R(2*K),AMASS(2*K,2*k),K=1,NN)
 156  format(8x,3f11.6)
      WRITE(60,157)(K,R(2*K-1),R(2*K),AMASS(2*K,2*k),K=1,NN)
157   FORMAT (1H1,14X,11HCOORDINATES,23X,5HLOADS// 
     19X,1HX,9X,1HY,9X,'MASS'//(I4,3F10.0))
      READ(50,151)(NP(L),NM(L),S(L),L=1,nb)
 151  FORMAT(2I5,8X,E10.6)
      WRITE(60,160)(L,NP(L),NM(L),S(L),L=1,NB)
 160  FORMAT(1H1,3X,'MEMBER',5X,'+ END',5X,'- END',6X
     1 ,'AREA'//(3I10,E20.8))
      NNN = NN - NS 
      N=2*NNN
      CALL OPT()
      STOP
      END
C
C
c
      SUBROUTINE OPT()
      DIMENSION NP(100),NM(100),S(100)
     1 ,AMASS(50,50)
      double precision r(100),uvec(2),c1,c(100,100)
      common NP,NM,S,R,amass
      COMMON /DAT/E,NB,NN,NS,N,NNN,MAXC
      dimension CB(100,100),an(100,100),delta(100),DELA(100)
      dimension alen(100),itype(100),EVEC(50,50),EVAL(50)
      DIMENSION xub(100),xlb(100),alp(100,100)
     1 ,b(100),dsol(100),xsol(100),f(100),BL(100),BU(100)
      SIGA=20000.
      do 6 i=1,n
      do 6 j=1,n
    6 IF(I.NE.J)amass(i,j)=0.
      do 7 l=1,nn 
      AMASS(2*L-1,2*l-1)=AMASS(2*L,2*l)/386.4
    7 AMASS(2*L,2*l)  =AMASS(2*L-1,2*l-1)
      OMEGA2=1757.
      DO 1 I=1,NB
      DO 1 J=1,N
    1 AN(I,J)=0.
      DO 999 L=1,NB
      K = 2*NP(L) 
      M = 2*NM(L) 
      CALL UNITV(K,M,C1,UVEC,R)
      ALEN(L)=c1
      DELA(L)=SIGA*C1/E
      IF (K.GT.N) GO TO 2
      AN(L,K-1)=UVEC(1)
      AN(L,K  )=UVEC(2)
   2  IF(M.GT.N) GO TO 999
      AN(L,M-1)=-UVEC(1)
      AN(L,M  )=-UVEC(2)
 999  CONTINUE
C
C
c     scale for displacements
C
      do 9997 iter=1,40
      DO 30 I = 1,N
      DO 30 J = 1,N 
   30 C(I,J) = 0. 
      DO 9999 L=1,NB
      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)
 9999 CONTINUE
      do 8 i=1,n
      do 8 j=1,n
C      WRITE(60,*)I,J,C(I,J),AMASS(I,J)
    8 cB(i,j)=c(i,j)
      CALL GVCSP(N,AMASS,50,CB,100,EVAL,EVEC,50)
      WRITE(60,*)EVAL(1),(I,EVEC(I,1),I=1,N)
      RATIOO=OMEGA2*EVAL(1)
      WRITE(60,*)'...SCALING',RATIOO
      PHI=0.
      NB1=NB-1
      do 88 i=1,nb1
      s(i)=ratioo*s(i)
   88 PHI=PHI+DELA(I)*DELA(I)*S(I)*E/ALEN(I)
      WRITE(60,*) '...PHI',PHI
      ALAM=PHI/(OMEGA2)
C
c     NORMALIZE EIGENVECTOR
      SUM=0.
      DO 555 I=1,N
  555 SUM=SUM+EVEC(I,1)*EVEC(I,1)*AMASS(I,I)
      BETA=1./SQRT(SUM)
      DO 556 I=1,N
  556 EVEC(I,1)=EVEC(I,1)*BETA
      WRITE(60,611)BETA,(i,EVEC(I,1),I=1,N)
  611 FORMAT(E20.8/(I5,E20.8))
c
      do 131 i=1,NB
      DELTA(I)=0.
      do 131 j=1,N
 131  DELTA(I)=DELTA(I)+AN(I,J)*EVEC(J,1)
  61  format(e20.8/ (i5,2e20.8))
      volume=0.
      do 71 i=1,nb
      IF(I.NE.NB)volume=volume+alen(i)*s(i)
   71 if(i.ne.nb)s(i)=s(i)*ABS(DELTA(I))/
     1SQRT(DELA(I)*dela(i)*omega2/phi)
      write(60,*) '*** volume', volume,iter
      WRITE(60,611) PHI,(I,S(I),I=1,NB)
 9997 continue
      RETURN
      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
