C     2D TRUSS Geometric Optimization (GEOM1.for)
C     NONLINEAR VERSION
      use IMSL
      DIMENSION NP(100),NM(100),S(100),PSAVE(100),FSAVE(100)
     & ,ant(50,50),p(50),cb(50,50),antb(50,50),bl(50),bu(50)
     & ,irtype(50),xlb(50),xub(50),xsol(50),dsol(50),antaf(50)
     & ,alen(50)
      DOUBLE PRECISION R(100),C(100,100),UVEC(2),C1,D1,
     1 F1,F2,fac1,C2
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 30.0D06 
      MAXC=100
      fac1=1.
    5 READ(50,2,END=299) NB,NN,NS,NSTEP,NIT
      IF(NSTEP.EQ.0) NSTEP=1
      IF(NIT.EQ.0) NIT=1
    2 FORMAT (5I5) 
      WRITE(60,1)NB,NN,NS,NSTEP,NIT
    1 FORMAT(I5,'  NO. MEMBERS'/I5,'  NO. NODES'/I5,'  NO. SUPPORTS'
     1 /I5,'  NO. LOAD STEPS'/I5,'  NO.ITERATIONS'//)
      NNS=NN-NS 
      N=2*NNS
      nmov=6
      READ(50,156)(R(2*K-1),R(2*K),PSAVE(2*K-1),
     1 PSAVE(2*K),K=1,NN)
      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,25X,11HCOORDINATES,40X,5HLOADS// 
     114X,1HX,19X,1HY,18X,2HPX,18X,2HPY,//(I4,4D20.8))
156   FORMAT (8X,4F11.6) 
      WRITE(60,159) 
159   FORMAT (1H1,3X,6HMEMBER,5X,5H+ END,5X,5H- END,16X,4HAREA,11X,
     1 9HPRESTRESS//)
      READ(50,151)(NP(L),NM(L),S(L),FSAVE(L),L=1,NB)
      WRITE(60,160)(L,NP(L),NM(L),S(L),FSAVE(L),L=1,NB)
151   FORMAT (2I5,8X,2E10.6) 
160   FORMAT (3I10,2E20.8) 
C     
C     START LOADSTEPS AND ITERATIONS
      nit=20
      DO 997 ITER=1,NIT
      WRITE(60,897) ITER,LDSTP
  897 FORMAT(///' ****ITERATION NUMBER',I4/ 
     1          '     LOAD STEP       ',I4)
C
C     SET UP SYSTEM MATRIX
C
      DO 904 I=1,N 
      P(I)=PSAVE(I)
      DO 904 J=1,N
      ant(i,j)=0.
  904 C(I,J)=0. 
      DO 999 L=1,NB
      s(l)=0.
      K = 2*NP(L) 
      M = 2*NM(L) 
      CALL UNITV(K,M,C1,UVEC,R)
      alen(l)=c1
      IF(K.GT.N) GO TO 888
      ant(k-1,l)=uvec(1)
      ant(k  ,l)=uvec(2)
  888 IF(M.GT.N) GO TO 887
      ant(m-1,l)=-uvec(1)
      ant(m  ,l)=-uvec(2)
  887 CALL INSERT(C,K,M,UVEC,MAXC,N,E,S(L),C1,FSAVE(L))
 999  CONTINUE
      do 3 i=1,n
      do 3 j=1,n
      antb(i,j)=ant(i,j)
    3 cb(i,j)=c(i,j)
      do 33 i=1,n
      do 33 j=1,nb
   33 cb(i,j+nmov)=ant(i,j)
      ipath=1
      lda=50
      nvar=nmov+nb
      call lslrg(n,antb,lda,p,ipath,fsave)
      write(60,*)(i,fsave(i),i=1,nb)
      if(iter.eq.1) go to 997
      do 11 i=1,n
      antaf(i)=0.
      bu(i)=0.
      bl(i)=0.
      irtype(i)=3
      do 11 j=1,nb
   11 antaf(i)=antaf(i)+ant(i,j)*abs(fsave(j))
      nmov1=nmov+1
      do 111 i=nmov1,nvar
  111 antaf(i)=alen(i-nmov)*sign(1.,fsave(i-nmov))
      do 4 i=1,nmov
      xub(i)= .1*r(i)
    4 xlb(i)=-.1*r(i)
      nmov1=nmov+1
      do 44 i=nmov1,nvar
      xub(i)= 1.*abs(fsave(i-nmov))
   44 xlb(i)=-1.*abs(fsave(i-nmov))
      write(60,*)((i,j,Cb(i,j),j=1,nvar),i=1,nmov)
      write(60,*)(i,antaf(i),i=1,nvar)
      call dlprs(n,nvar,cb,lda,bl,bu,antaf,irtype,xlb,
     & xub,obj,xsol,dsol)
C
C
  998 CONTINUE
C
C     UPDATE COORDINATES
      con=-1.
      DO 444 I=1,nmov
      con=-1.*con
      write(60,*) xsol(i)
  444 if(con.lt.0.) R(I)=R(I)+xsol(I)
      r(6)=r(2)
      vol=0.
      nb1=nb-1
      do 944 i=1,nb1
  944 vol=vol+alen(i)*abs(fsave(i))
      write(60,*) 'volume', vol
      WRITE(60,158)(K,R(2*K-1),R(2*K),K=1,NNS)
158   FORMAT (1H1,11X,19HUPDATED COORDINATES// 
     114X,1HX,19X,1HY,//(I4,2D20.8))
  997 CONTINUE
  299 STOP
      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,FSAVE)
      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
      fac1=1.
      IF(I.NE.J) fac1=-1.
      DO 3 L=1,2
      I1=K1-2+L
      DO 3 L1=1,2
      J1=M1-2+L1
      C(I1,J1)=C(I1,J1)+UVEC(L)*UVEC(L1)*(S*E-FSAVE)*fac1/C1
    3 IF(L.EQ.L1) C(I1,J1)=C(I1,J1)+fac1*FSAVE/C1
    2 M1=M
    1 K1=M
      RETURN
      END
