C     PLANE TRUSS-LP FORMULATION USING DISPLACEMENT CONSTRAINT
c     AND STRESS CONSTRAINT
      use imsl
      DIMENSION NP(100),NM(100),S(100),for(900),R(900)
     1 ,SIGALL(2,100),DALL(2,100),NJT(100),DCONS(100,3)
     1 ,SSAVE(100),DELTA(2,100),FSAVE(2,100),prod(50,50)
     1 ,prod2(50,50)
      DOUBLE PRECISION P(100),C(100,100),UVEC(2),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100)
      common NP,NM,S,FOR,R,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,UVEC,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNN,MAXC
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 29.0D06
100   READ(50,150)NB,NN,NS 
150   FORMAT (3I5) 
      WRITE(60,1)NB,NN,NS
    1 FORMAT(I5,'  NO. MEMBERS'/I5,'  NO. NODES'/I5,
     1'  NO.SUPPORTS'//)
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 29.0D06 
      READ(50,156)(R(2*K-1),R(2*K),PSAVE(1,2*K-1),PSAVE(1,2*K),K=1,NN)
  156 FORMAT (8X,4F11.6) 
      WRITE(60,157)(K,R(2*K-1),R(2*K),PSAVE(1,2*K-1),
     1 PSAVE(1,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
      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))
C     CONSTRAINTS
C
      READ(50,651)NDCONS
 651  FORMAT(I10,2F10.0)
      READ(50,552)(NJT(I),DCONS(I,1),DCONS(I,2)
     1 ,I=1,NDCONS)
      WRITE(60,553)(I,NJT(I),DCONS(I,1),DCONS(I,2)
     1 ,I=1,NDCONS)
 552  FORMAT(I5,2F10.0)
 553  FORMAT(1H1,'DISPLACEMENT CONSTRAINTS'/6X,'JT.', 10X,
     1 'X',9X,'Y',8X,'Z'//( 2I5,3F10.4))
      READ(50,550)(SIGALL(1,I),SIGALL(2,I),I=1,NB)
      WRITE(60,551)(I,SIGALL(1,I),SIGALL(2,I),I=1,NB)
 550  FORMAT(2F10.2)
 551  FORMAT(1H1,' ALLOWABLE STRESSES'/2X,'MEMBER',14X
     1 ,'STRESSES'//(I10,2F10.0))
      CALL ANAL()
      CALL OPT()
      STOP
      END
C
C
      SUBROUTINE ANAL()
C     PLANE TRUSS ANALYSIS
      DIMENSION NP(100),NM(100),S(100),for(900),R(900)
     1 ,SIGALL(2,100),DALL(2,100),NJT(100),DCONS(100,3)
     1 ,SSAVE(100),DELTA(2,100),FSAVE(2,100),prod(50,50)
     1 ,prod2(50,50)
      DOUBLE PRECISION P(100),C(100,100),UVEC(2),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100)
      common NP,NM,S,FOR,R,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,UVEC,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNN,MAXC
      DIMENSION PTEMP(100)
      do 9999 LD=1,1
      DO 555 I=1,N
 555  PTEMP(I)=PSAVE(LD,I)
      WRITE(60,157)(K,R(2*K-1),R(2*K),PSAVE(1,2*K-1),
     1 PSAVE(1,2*K),K=1,NN)
157   FORMAT (1H1,16X,11HCOORDINATES,28X,5HLOADS/
     1 14X,1HX,17X,1HY,16X,2HPX,16X,2HPY//(I4,4D18.8))
C 
c
C
C     SET UP SYSTEM MATRIX
C
      DO 30 I = 1,N
      P(I)=PTEMP(I)
      DO 30 J = 1,N 
   30 C(I,J) = 0. 
      WRITE(60,159) 
      DO 999 L=1,NB
      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
      DO 720 I=1,N
 720  DEL(LD,I)=P(I)
      WRITE(60,161)(I,P(2*I-1),P(2*I),I=1,NNN)
  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)
      FSAVE(LD,I)=F1
      DELTA(LD,I)=D1
      WRITE(60,1000) I,D1,F1,F2 
  998 CONTINUE
 9999 CONTINUE
      RETURN
 1000 FORMAT (I10,3D20.8) 
  159 FORMAT (1H1,3X,6HMEMBER,5X,5H+ END,5X,5H- END,6X,4HAREA//) 
      END 
c
      SUBROUTINE OPT()
      DIMENSION NP(100),NM(100),S(100),for(900),R(900)
     1 ,SIGALL(2,100),DALL(2,100),NJT(100),DCONS(100,3)
     1 ,SSAVE(100),DELTA(2,100),FSAVE(2,100),prod(50,50)
     1 ,prod2(50,50)
      DOUBLE PRECISION P(100),C(100,100),UVEC(2),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100)
      common NP,NM,S,FOR,R,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,UVEC,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNN,MAXC
      dimension alen(100),itype(100)
      dimension xub(100),xlb(100),alp(100,100)
     1 ,bl(100),dsol(100),xsol(100),f(100),bu(100)
c
c     COMPUTE THE MATRIX N
C
      DO 1 I=1,NB
c      s(i)=1.
      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
      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      call anal()
C
C     CHECK STRESS CONSTRAINTS
C
      RAT2=0.
      RATIO=0.
c      IF(E.NE.0) GO TO 9333
      DO 3 I=1,NB
      STRESS1=FSAVE(1,I)/S(I)
c      STRESS2=FSAVE(2,I)/s(I)
      IF(STRESS1. GT. 0.) GO TO 4
      RAT1=STRESS1/SIGALL(2,I)
      if(fsave(1,i).ne.0.)
     1 s(i)=fsave(1,i)/sigall(2,i)
      GO TO 5
   4  RAT1=STRESS1/SIGALL(1,I)
      if(fsave(1,i).ne.0.)
     1 s(i)=fsave(1,i)/sigall(1,i)
   5  CONTINUE
C      IF(STRESS2. GT. 0.) GO TO 14
C      RAT2=STRESS2/SIGALL(2,I)
C      GO TO 15
C   14 RAT2=STRESS2/SIGALL(1,I)
C   15 CONTINUE
      RATIO=AMAX1(RATIO,RAT1,RAT2)
      WRITE(60,*) '***RATIOS ',I,RAT1,RAT2,RATIO
    3 CONTINUE
      call anal()
C
C     CHECK DISPLACEMENT CONSTRAINTS
C      do 9997 iter=1,40
C
 9333 CONTINUE
      ratioo=0.
      DO 6 I=1,NDCONS
      JOINT=NJT(I)
      IF(DCONS(I,1).NE.0.)
     1 RAT1=DABS(DEL(1,2*JOINT-1))/DCONS(I,1)
      IF(DCONS(I,2).NE.0.)
     1 RAT2=DABS(DEL(1,2*JOINT))/DCONS(I,2)
      ratioo=amax1(ratioo,rat1,rat2)
      WRITE(60,*) I,RAT1,RAT2,ratioo
    6 CONTINUE
C
c     scale for displacements
      if(ratioo.lt.1.) go to 814
      do 88 i=1,nb
  88  s(i)=ratioo*s(i)
 814  continue
      do 9997 iter=1,40
      call anal()
      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
      call dlinds(n,c,maxc,c,maxc)
      do 20 i=1,n
      do 20 k=1,nb
      prod(i,k)=0.
      do 20 j=1,n
  20  prod(i,k)=prod(i,k)-c(i,j)*an(k,j)
      do 21 i=1,nb
      do 21 k=1,nb
      prod2(i,k)=0.
      do 21 j=1,n
  21  prod2(i,k)=prod2(i,k)+an(i,j)*prod(j,k)
      nrows=0
c      IF(E.GT.0.) GO TO 569
      do 31 i=1,nb
      do 31 j=1,1
      if(fsave(j,i).lt.0.) go to 32
      rat=(fsave(j,i)/s(i))/sigall(1,i)
      if(rat.lt..8)go to 31
      nrows=nrows+1
      do 34 k=1,nb
      alp(nrows,k)=prod2(i,k)*(E*DELTA(J,K)/ALEN(K))*(E/ALEN(I))
   34 continue
      ITYPE(NROWS)=1
      bu(nrows)=sigall(1,i)-fsave(j,i)/s(i)
      go to 31
   32 continue
      rat=(fsave(j,i)/s(i))/sigall(2,i)
      if(rat.lt..8)go to 31
      nrows=nrows+1
      do 234 k=1,nb
      alp(nrows,k)=prod2(i,k)*(E*DELTA(J,K)/ALEN(K))*(E/ALEN(I))
  234 continue
      iTYPE(NROWS)=2
      bl(nrows)=sigall(2,i)-fsave(j,i)/s(i)
 31   continue
c
c     displacement constraints
C
 569  CONTINUE
      do 131 i=1,ndcons
      joint=njt(i)
      do 131 j=1,1
      do 131 k=1,2
      IF(DCONS(I,K).EQ.0.) GO TO 131
      ncomp=2*joint-2+k
      if(del(j,ncomp).lt.0.) go to 132
      rat=dabs(del(j,ncomp))/dcons(i,k)
      if(rat.lt..8)go to 131
      nrows=nrows+1
      do 134 k1=1,nb
      alp(nrows,k1)=prod(ncomp,k1)*E*delta(j,k1)/alen(k1)
  134 continue
      iTYPE(NROWS)=1
      bu(nrows)=dcons(i,k)-del(j,ncomp)
      go to 131
  132 continue
      rat=dabs(del(j,ncomp))/dcons(i,k)
      if(rat.lt..8)go to 131
      nrows=nrows+1
      do 334 k1=1,nb
      alp(nrows,k1)=prod(ncomp,k1)*E*delta(j,k1)/alen(k1)
  334 continue
      iTYPE(NROWS)=2
      bl(nrows)=-dcons(i,k)-del(j,ncomp)
 131  continue
      do 70 i=1,nb
      f(i)=alen(i)
      xlb(i)=-.2*s(i)
  70  xub(i)=.2*s(i)
      write(60,*)' *** nrows',nrows
C      write(60,*)((alp(i,j),j=1,nb),i=1,nrows)
      call dlprs(nrows,nb,alp,maxc,bl,bu,f,itype,xlb,xub,obj,xsol,dsol)
      write(60,61)iter,obj,(i,xsol(i),s(i),i=1,nb)
  61  format(i5,e20.8/ (i5,2e20.8))
      volume=0.
      do 71 i=1,nb
      volume=volume+alen(i)*s(i)
   71 s(i)=amax1(s(i)+real(xsol(i)),.01)
      write(60,*) '*** volume', volume
 9997 continue
      RETURN
      END
C 
      SUBROUTINE UNITV(K,M,C1,UVEC,R) 
      DOUBLE PRECISION C1,UVEC(2)
      DIMENSION R(1)
      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
      FFAC=1.
      IF(I.NE.J) FFAC=-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*FFAC/C1
    2 M1=M
    1 K1=M
      RETURN
      END
