C     PLANE FRAME-LP FORMULATION USING DISPLACEMENT CONSTRAINT
      use imsl
      DIMENSION NP(100),MI(100),A(100),for(900),AL(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),ssi(100),TH(100) 
      DOUBLE PRECISION P(100),C(100,100),R(3,3),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100),SK(3,3),SNP(3,3),SNM(3,3)
     1,aai(3,3),AJ(3,3),NRP(3,3),NRM(3,3),ANG
      common NP,MI,A,FOR,AL,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,R,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
     1,ssi,TH,SK,SNP,SNM,aai,AJ,NRP,NRM,ANG
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNs,MAXC,PI
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      DO 6 I=1,3
      DO 6 J=1,3
      R(I,J)=0.
      SK(I,J)=0.
      SNP(I,J)=0.
    6 SNM(I,J)=0.
      R(3,3)=1. 
      SNP(1,1)=1.
      SNP(2,3)=1.
      SNM(1,1)=-1.
      SNM(3,3)=1.
      PI=3.14159    /180. 
      E=29000000. 
    5 READ(50,2)NB,NN,NS
    2 FORMAT (3I5) 
      WRITE(60,1)NB,NN,NS
    1 FORMAT(I5,'  NO. MEMBERS'/I5,'  NO. NODES'/I5,'  NO. SUPPORTS'//)
      NNS=NN-NS 
      N=3*NNS
      READ(50,3) (  psave(1,3*I-2),psave(1,3*I-1),psave(1,3*I),I=1,NNS ) 
    3 FORMAT(3D10.2)
      WRITE(60,903)(I,PSAVE(1,3*I-2),psave(1,3*I-1),psave(1,3*I),
     1 I=1,NNS)
  903 FORMAT(1H1,11HJOINT LOADS /13X,2HPX,18X,2HPY,19X,1HM//
     1 (I4,3D20.8))
      WRITE            (60,901) 
  901 FORMAT(18H1MEMBER PROPERTIES /16X,4HAREA,9X,6HLENGTH,14X,1HI,
     1 10X,5HANGLE,5H +END,5H -END)
      DO 926 K=1,NB
      READ(50,31) A(K),AL(K),ssi(K),TH(K),NP(K),MI(K) 
   31 FORMAT(4E10.2,2I5)
      WRITE(60,900) K, A(K),AL(K),ssi(K),TH(K),NP(K),MI(K) 
  900 FORMAT(I5,4E15.8,2I5)
  926 continue
C
C     INITIALIZE PARAMETERS/ARRAYS
C
C
      E = 29.0D06 
C     CONSTRAINTS
C
      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))
      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))
      CALL ANAL()
      CALL OPT()
      STOP
      END
C
C
      SUBROUTINE ANAL()
      DIMENSION NP(100),MI(100),A(100),for(900),AL(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),ssi(100),TH(100)
      DOUBLE PRECISION P(100),C(100,100),R(3,3),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100),SK(3,3),SNP(3,3),SNM(3,3)
     1,aai(3,3),AJ(3,3),nrp(3,3),NRM(3,3),ANG
      common NP,MI,A,FOR,AL,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,R,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
     1,ssi,TH,SK,SNP,SNM,aai,AJ,NRP,NRM,ANG
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNs,MAXC,PI
      DIMENSION PTEMP(100)
      do 9999 LD=1,1
      DO 555 I=1,N
 555  PTEMP(I)=PSAVE(LD,I)
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,901) 
  901 FORMAT(18H1MEMBER PROPERTIES /16X,4HAREA,9X,6HLENGTH,14X,1HI,
     1 10X,5HANGLE,5H +END,5H -END)
      DO 926 K=1,NB
      WRITE(60,900) K, A(K),AL(K),ssi(K),TH(K),NP(K),MI(K) 
  900 FORMAT(I5,4E15.8,2I5)
      ANG=TH(K)*PI
      CALL RNK(R,SK,SNP,SNM,NRP,NRM,AL,ssi,A,E,ANG,K)
      IF(NP(K).GT.NNS) GO TO 23
      CALL PROD3(NRP,SK,NRP,aai)
      CALL INSERT(C,MAXC, NP(K),NP(K),aai)
      IF(MI(K).GT.NNS) GO TO 926
      CALL PROD3(NRP,SK,NRM,aai)
      CALL INSERT(C,MAXC, NP(K),MI(K),aai)
      DO 14 I=1,3
      DO 14 J=1,3
   14 AJ(I,J)=aai(J,I)
      CALL INSERT(C,MAXC, MI(K),NP(K),AJ)
   23 CALL PROD3(NRM,SK,NRM,aai)
      CALL INSERT(C,MAXC, MI(K),MI(K),aai)
  926 CONTINUE
C
C     SOLVE FOR DISPLACEMENTS
C
  927 M=N-1 
      DO 91 I=1,M 
      L=I+1 
      DO 91 J=L,N 
      IF (C(J,I)) 93,91,93 
   93  DO 92 K=L,N 
   92  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) 
   91  CONTINUE 
      P (N)=P(N)/C(N,N) 
      DO 94 I=1,M 
      K=N-I 
      L=K+1 
      DO 95 J=L,N 
   95  P(K)=P(K)-P (J)*C(K,J) 
   94  P (K)=P(K)/C(K,K)
      DO 720 I=1,N
 720  DEL(LD,I)=P(I)
      WRITE (60,231)(I,P(3*I-2),P(3*I-1),P(3*I),I=1,NNS ) 
  231 FORMAT(20H1JOINT DISPLACEMENTS /13X,2HDX,16X,2HDY,16X,2HTH/
     1 (I3,3X,3(D15.8,3X)))
C
C     COMPUTE MEMBER FORCES AND DISPLACEMENTS 
C
      WRITE (60,230) 
  230 FORMAT(28H1MEMBER DISPLACEMENTS-FORCES/15X,2HDL,9X,3HAL+,9X,
     1 3HAL-,11X,1HT,10X,2HM+,10X,2HM-) 
      DO 207 I=1,NB
      ANG=TH(I)*PI
      CALL RNK(R,SK,SNP,SNM,NRP,NRM,AL,ssi,A,E,ANG,I)
      DO 222 J=1,3 
  222 aai(2,J)=0. 
      IF(NP(I).GT.NNS) GO TO 213
      DO 208 J=1,3 
      DO 208 K=1,3 
      L4=3*NP(I)-3+K
  208 aai(2,J)=aai(2,J)+NRP(J,K)*P(L4)
  213 IF(MI(I).GT.NNS) GO TO 215
      DO 308 J=1,3 
      DO 308 K=1,3 
      L4=3*MI(I)-3+K
  308 aai(2,J)=aai(2,J)+NRM(J,K)*P(L4)
  215 DO 226 J=1,3 
       aai(1,J)=0. 
      DO 226 K=1,3 
  226  aai(1,J)= aai(1,J)+SK(J,K)*aai(2,K)
      DO 1226 J=1,3
      FSAVE(LD,3*I-3+J)=aai(1,J)
 1226 DELTA(LD,3*I-3+J)=aai(2,J)
  207 WRITE(60,217) I,aai(2,1),aai(2,2),aai(2,3), aai(1,1), 
     6 aai(1,2), aai(1,3) 
  217 FORMAT (I5,6D12.5)
  999 CONTINUE
 9999 continue
      RETURN
      END
C
c
      SUBROUTINE OPT()
      DIMENSION NP(100),MI(100),A(100),for(900),AL(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),ssi(100),TH(100)
      DOUBLE PRECISION P(100),C(100,100),R(3,3),PSAVE(2,100)
     1,C1,D1,F1,F2,FFAC,DEL(2,100),AN(100,100),SK(3,3),SNP(3,3),SNM(3,3)
     1,aai(3,3),AJ(3,3),nrp(3,3),NRM(3,3),ANG
      common NP,MI,A,FOR,AL,SIGALL,DALL,NJT,DCONS,SSAVE,P,C
     1,R,PSAVE,C1,D1,F1,F2,FFAC,DEL,DELTA,FSAVE,AN,prod,prod2
     1,ssi,TH,SK,SNP,SNM,aai,AJ,NRP,NRM,ANG
      COMMON /DAT/E,NB,NN,NS,N,NDCONS,NNs,MAXC,PI
      dimension alen(100),itype(100)
      dimension xub(100),xlb(100),alp(100,100)
     1 ,bl(100),dsol(100),xsol(100),f(100),bu(100)
     1 , x2al(100,100),prodn(100,100),prod2n(100,100)
c
c     COMPUTE THE MATRIX N
C
      NB3=3*NB
      DO 1 I=1,NB3
      DO 1 J=1,N
    1 AN(I,J)=0.
      DO 999 L=1,NB
      ang=th(l)*pi
      CALL RNK(R,SK,SNP,SNM,NRP,NRM,AL,ssi,A,E,ANG,L)
      K = 3*NP(L) 
      M = 3*MI(L) 
      IF (K.GT.N) GO TO 2
      DO 129 L1=1,3
      DO 129 L2=1,3
  129 AN(3*L-3+L1,K-3+L2)=NRP(L1,L2)
   2  IF(M.GT.N) GO TO 999
      DO 1129 L1=1,3
      DO 1129 L2=1,3
 1129 AN(3*L-3+L1,M-3+L2)=NRM(L1,L2)
 999  CONTINUE
c      do 2129 i=1,n
c      p(i)=0.
c      do 2129 j=1,nb3
c2129 p(i)=p(i)+an(j,i)*fsave(1,j)
c      write(60,*)(i,p(i),i=1,n)
C
C     CHECK STRESS CONSTRAINTS
C
c      do 9997 iter=1,40
      RATIO=0.
      DO 3 I=1,NB
      t=fsave(1,3*i-2)
      amp=fsave(1,3*i-1)
      amm=fsave(1,3*i)
      STRESS1=abs(T)/a(i)+amax1(abs(amp),abs(amm))/smod(a(i))
      RAT1=STRESS1/SIGALL(1,I)
      RATIO=AMAX1(RATIO,RAT1)
      WRITE(60,*) '***RATIOS ',I,RAT1,RATIO
      a(i)=.465*sqrt(((1.*rat1*smod(a(i))+290.)**2-84100.)/60.6)
      ssi(i)=aimod(a(i))
    3 CONTINUE
      call anal()
C
C     CHECK DISPLACEMENT CONSTRAINTS
C
 9333 CONTINUE
      ratioo=0.
      if(ndcons.eq.0) go to 349
      DO 6 I=1,NDCONS
      JOINT=NJT(I)
      IF(DCONS(I,1).NE.0.)
     1 RAT1=DABS(DEL(1,3*JOINT-2))/DCONS(I,1)
      IF(DCONS(I,2).NE.0.)
     1 RAT2=DABS(DEL(1,3*JOINT)-1)/DCONS(I,2)
      ratioo=amax1(ratioo,rat1,rat2)
      WRITE(60,*) I,RAT1,RAT2,ratioo
    6 CONTINUE
C
c     scale for displacements
      if(ratioo.le..8) go to 349
      do 88 i=1,nb
      a(i)=.465*sqrt(ratioo*aimod(a(i)))
      ssi(i)=aimod(a(i))
      call papms(fsave,i,sigp,sigm,a(i))
 88   write(60,*)i,sigp,sigm
 349  continue
c
      do 9997 iter=1,40
      call anal()
c     CONSTRUCT THE MATRIX KE
C
      DO 30 I = 1,N
      DO 30 J = 1,N 
   30 C(I,J) = 0. 
      DO 926 K=1,NB
      WRITE(60,900) K, A(K),AL(K),ssi(K),TH(K),NP(K),MI(K) 
  900 FORMAT(I5,4E15.8,2I5)
      ANG=TH(K)*PI
      CALL RNK(R,SK,SNP,SNM,NRP,NRM,AL,ssi,A,E,ANG,K)
      IF(NP(K).GT.NNS) GO TO 23
      CALL PROD3(NRP,SK,NRP,aai)
      CALL INSERT(C,MAXC, NP(K),NP(K),aai)
      IF(MI(K).GT.NNS) GO TO 926
      CALL PROD3(NRP,SK,NRM,aai)
      CALL INSERT(C,MAXC, NP(K),MI(K),aai)
      DO 14 I=1,3
      DO 14 J=1,3
   14 AJ(I,J)=aai(J,I)
      CALL INSERT(C,MAXC, MI(K),NP(K),AJ)
   23 CALL PROD3(NRM,SK,NRM,aai)
      CALL INSERT(C,MAXC, MI(K),MI(K),aai)
  926 CONTINUE
      call dlinds(n,c,maxc,c,maxc)
      do 20 i=1,n
      do 20 k=1,nb3
      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,nb3
      do 21 k=1,nb3
      prod2(i,k)=0.
      do 21 j=1,n
  21  prod2(i,k)=prod2(i,k)+an(i,j)*prod(j,k)
      do 22 i=1,nb3
      do 22 j=1,nb
  22  x2al(i,j)=0.
      do 723 i=1,nb
      x2al(3*i-2,i)=e*delta(1,3*i-2)/al(i)
      x2al(3*i-1,i)=e*9.184*a(i)*(4.*delta(1,3*i-1)+2.*
     1 delta(1,3*i))/al(i)
 723  x2al(3*i,i)=e*9.184*a(i)*(2.*delta(1,3*i-1)+4.*
     1 delta(1,3*i))/al(i)
      do 24 i=1,n
      do 24 j=1,nb
      prodn(i,j)=0.
      do 24 k=1,nb3
  24  prodn(i,j)=prodn(i,j)+prod(i,k)*x2al(k,j)
      do 25 i=1,nb3
      do 25 j=1,nb
      prod2n(i,j)=0.
      do 25 k=1,nb3
  25  prod2n(i,j)=prod2n(i,j)+prod2(i,k)*x2al(k,j)
c
C     STRESS CONSTRAINTS
      nrows=0
      do 31 i=1,nb
      do 31 j=1,1
      call papms(fsave,i,sigp,sigm,a(I))
      cons=sign(1.,fsave(1,3*i-1))
      amoma=fsave(1,3*i-1)
      c1=4.
      c2=2.
      c11=1.
      c12=0.
      if(abs(sigm).le.abs(sigp))go to 344
      cons= sign(1.,fsave(1,3*i))
      amoma=fsave(1,3*i)
      c1=2.
      c2=4.
      c11=0.
      c12=1.
  344 continue
      rat=amax1(abs(sigp),abs(sigm))/sigall(1,i)
      if(rat.lt..8)go to 31
      nrows=nrows+1
      do 34 k=1,nb
      alp(nrows,k)=E*prod2n(3*i-2,k)*sign(1.,fsave(1,3*i-2))/al(i)
c
     1 +c1*prod2n(3*i-1,k)*(E*aimod(a(i))/al(i))/
     1 smod(a(i))*cons
c
     1 +c2*prod2n(3*i,k)*(E*aimod(a(i))/al(i))/
     1 smod(a(i))*cons
   34 continue
      ITYPE(NROWS)=1
      bu(nrows)=sigall(1,i)-abs(fsave(1,3*i-2))/a(i)
     1-abs(amoma)/smod(a(i))
 31   continue
c
c     displacement constraints
C
 569  CONTINUE
      if(ndcons.eq.0) go to 1131
      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=3*joint-3+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)=prodn(ncomp,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)=prodn(ncomp,k1)
  334 continue
      iTYPE(NROWS)=2
      bl(nrows)=-dcons(i,k)-del(j,ncomp)
 131  continue
 1131 continue
      do 70 i=1,nb
      f(i)=al(i)
      xlb(i)=-.2*a(i)
  70  xub(i)=.2*a(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),a(i),i=1,nb)
  61  format(i5,e20.8/ (i5,2e20.8))
      volume=0.
      do 71 i=1,nb
      volume=volume+al(i)*a(i)
      a(i)=amax1(a(i)+real(xsol(i)),.01)
      ssi(i)=aimod(a(i))
      call papms(fsave,i,sigp,sigm,a(i))
      z=smod(a(i))
      write(60,*)i,a(i),ssi(i),sigp,sigm,z
   71 continue
      write(60,*) 'iteration',iter,'*** volume', volume
 9997 continue
      RETURN
      END
C
      SUBROUTINE RNK(R,SK,SNP,SNM,NRP,NRM,AL,ssi,A,E,ANG,K)
      DIMENSION AL(1),ssi(1),A(1)
      DOUBLE PRECISION R(3,3),SK(3,3),SNP(3,3),SNM(3,3),NRP(3,3),
     1 NRM(3,3),ANG
      R(1,1)=DCOS(ANG) 
      R(2,2)=R(1,1) 
      R(1,2)=DSIN(ANG) 
      R(2,1)=-R(1,2) 
      SK(1,1)=E*A(K)/AL(K) 
      SK(2,2)=E*4.*ssi(K)/AL(K) 
      SK(3,3)=SK(2,2) 
      SK(2,3)=SK(2,2)*.5 
      SK(3,2)=SK(2,3) 
      SNP(2,2)=-1./AL(K)
      SNP(3,2)=SNP(2,2) 
      SNM(2,2)=1./AL(K) 
      SNM(3,2)=SNM(2,2)
      DO 1 I=1,3 
      DO 1 J=1,3 
      NRP(I,J)=0.
      NRM(I,J)=0.
      DO 1 L=1,3 
      NRP(I,J)=NRP(I,J)+SNP(I,L)*R(L,J)
    1 NRM(I,J)=NRM(I,J)+SNM(I,L)*R(L,J)
      RETURN
      END
C
      SUBROUTINE INSERT(C,MAXC,I1,J1,A)
      DOUBLE PRECISION C(MAXC,MAXC),A(3,3)
      DO 1 I=1,3
      I2=3*I1-3+I
      DO 1 J=1,3
      J2=3*J1-3+J
    1 C(I2,J2)=C(I2,J2)+A(I,J)
      RETURN
      END
C
      SUBROUTINE PROD3(A,B,C,D)
      DOUBLE PRECISION A(3,3),B(3,3),C(3,3),D(3,3)
      DO 1 I=1,3 
      DO 1 J=1,3 
      D(I,J)=0. 
      DO 1 K=1,3 
      DO 1 L=1,3
    1 D(I,J)=D(I,J)+A(K,I)*B(K,L)*C(L,J)
      RETURN
      END
c
      function smod(A)
      smod=sqrt(60.6*(a/.465)**2+84100.)-290.
      end
c
      function aimod(a)
      aimod=(a/.465)**2
      end
c
      subroutine papms(fsave,mem,sigp,sigm,a1)
      dimension fsave(2,100)
      sigp=abs(fsave(1,3*mem-2)/a1)+abs(fsave(1,3*mem-1)/smod(a1))
      sigm=abs(fsave(1,3*mem-2)/a1)+abs(fsave(1,3*mem)/smod(a1))
      return
      end

