C     2D TRUSS Geometric Optimization (GEOM1.for)
C     NONLINEAR VERSION
      INCLUDE 'FGRAPH.FI'
      use IMSL
      DIMENSION NP(100),NM(100),S(100),PSAVE(100),FSAVE(100)
     & ,ant(70,70),p(70),cb(70,70),antb(70,70),bl(70),bu(70)
     & ,irtype(70),xlb(70),xub(70),xsol(70),dsol(70),antaf(70)
     & ,alen(70)
      DOUBLE PRECISION R(100),C(100,100),UVEC(2),C1,D1,
     1 F1,F2,fac1,C2
      Dimension awk(1),wk(2000),iwk(1000)
      ldawk=1
      MAXC=100
C
C     INITIALIZE PARAMETERS/ARRAYS
C
      E = 30.0D06
      fy=36000.
      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=5
    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=n
      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)
      iwrite=0
C     
C     START LOADSTEPS AND ITERATIONS
      nit=5
      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)*3.
      DO 904 J=1,N
      ant(i,j)=0.
  904 C(I,J)=0. 
      DO 999 L=1,NB
c      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)
      xs=0.
  887 CALL INSERT(C,K,M,UVEC,MAXC,N,E,xs,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=70
      nvar=nmov+nb
      call lslrg(n,antb,lda,p,ipath,fsave)
      write(60,*)'bar forces',(i,fsave(i),i=1,nb)
      do 632 j=1,nb
  632 CALL AREA(Fsave(j),FY,S(j),ALEN(j),E,J)
      do 11 i=1,n
      antaf(i)=0.
      bu(i)=0.
      bl(i)=0.
      irtype(i)=3
      do 11 j=1,nb
      CALL xderiV(DADF,DADL,E,FY,ALEN(j),S(j),Fsave(j),j)
   11 antaf(i)=antaf(i)+ant(i,j)*(s(j)+dadl)
      if(iter.eq.1) go to 2990
      nmov1=nmov+1
      do 111 i=nmov1,nvar
      j=i-nmov
      CALL xderiV(DADF,DADL,E,FY,ALEN(j),S(j),Fsave(j),j)
  111 antaf(i)=alen(i-nmov)*dadf
      do 4 i=1,nmov
      xub(i)= 10.*(1.-float(iter)/float(2*nit))
    4 xlb(i)=-xub(i)
      nmov1=nmov+1
      do 44 i=nmov1,nvar
      xub(i)= 1000.
   44 xlb(i)=-1000.
c      write(60,*)((i,j,Cb(i,j),j=1,nvar),i=1,nmov)
c      write(60,*)(i,antaf(i),i=1,nvar)
      call d2prs(n,nvar,cb,lda,bl,bu,antaf,irtype,xlb,
     & xub,obj,xsol,dsol,awk,ldawk,wk,iwk)
C
C
  998 CONTINUE
C
C     UPDATE COORDINATES
      con=-1.
      DO 444 I=1,14
      con=-1.*con
      write(60,*) xsol(i)
  444 if(i.ne.13) R(I)=R(I)+xsol(I)
c     special case for support
      r(32)=r(14)
 2990 vol=0.
      nb1=nb-2
      do 944 i=1,nb1
  944 vol=vol+alen(i)*S(I)
      write(60,*) 'volume', vol
      WRITE(60,158)(K,R(2*K-1),R(2*K),K=1,NN)
158   FORMAT (1H1,11X,19HUPDATED COORDINATES// 
     114X,1HX,19X,1HY,//(I4,2D20.8))
  997 CONTINUE
      CALL PLOT(r,NB, NN,NS, NP, nM,fSAVE,iwrite)
  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
c
      SUBROUTINE AREA(F,FY,S,ALEN,E,IBAR)
      if(f.ne.0.)go to 4
      s=0.01
      go to 3
   4  IF(F.LT.0.)GO TO 1
      S=F/FY
      go to 3
   1  CB=(3.14159**2)*E*(1.41**2)
      DO 2 I=1,4
      CON=.658**(FY*ALEN*ALEN/(CB*S))
      STR=-F-S*FY*CON
      STRCA=FY*CON*(-1.+S*ALOG(.658)*(FY*ALEN**2/(CB*S*S)))
      DS=-STR/STRCA
   2  S=S+DS
   3  WRITE(60,*)'area',IBAR,S
      RETURN
      END
C
      SUBROUTINE xderiV(DADF,DADL,E,FY,ALEN,S,F,ibar)
      IF(F.LT.0.)GO TO 1
      DADF=1./FY
      DADL=0.
      go to 3
   1  CB=(3.14159**2)*E*(1.41**2)
      CON=.658**(FY*ALEN*ALEN/(CB*S))
      CON1=FY*(CON-S*CON*ALOG(.658)*FY*ALEN*ALEN/(CB*S*S))
      DADF=-1./CON1
      CON2=(-1.+S*ALOG(.658)*fy*ALEN*ALEN/(CB*S*S))
      DADL=s*ALOG(.658)*(2.*FY*ALEN/(CB*s))/CON2
    3 continue
c   3  write(60,*)'dadf dadl',ibar,dadf,dadl
      RETURN
      END
C
C
      SUBROUTINE PLOT(r,NB, NN,NS, NP, MI,for,iwrite)
      INCLUDE 'FGRAPH.FD'
      DIMENSION  NP(1), MI(1), X(100), Y(100),for(1)
      DOUBLE PRECISION R(100)
      INTEGER*2 DUMMY,xk,yk,xm,ym,lx,ly
      RECORD /XYCOORD/ XY
      character*5  text
      character*8  text1
      CHARACTER*64 FONTPATH
      CHARACTER*20 LIST
      FONTPATH='\NEWFOR\lib\courb.fon'
      LIST="t'courb'"//'h6w6b'
      DUMMY = SETVIDEOMODE( $VRES16COLOR)
      DUMMY=REGISTERFONTS(FONTPATH)
      DUMMY=SETFONT(LIST)
      AMAXX=639-20
      AMAYY=479-20
      DO 333 I=1,NN
      X(I)=R(2*I-1)
  333 Y(I)=R(2*I)
c     find extent of picture window
      XMIN=X(1)
      XMAX=X(1)
      YMIN=Y(1)
      YMAX=Y(1)
      DO 2 I=1,NN
      XI=X(I)
      YI=Y(I)
      IF(XMIN.GT.XI) XMIN=XI
      IF(XMAX.LT.XI) XMAX=XI
      IF(YMIN.GT.YI) YMIN=YI
   2  IF(YMAX.LT.YI) YMAX=YI
c     scale to center of window
      SCALE = AMAX1((XMAX-XMIN)/AMAXX,(YMAX-YMIN)/AMAYY)
      XSHIFT = (XMAX+XMIN)/2.0 - 639/2*SCALE
      YSHIFT = (YMAX+YMIN)/2.0 - 479/2*SCALE
c     move and draw for each line
      DO 3 I=1,NB
      K=NP(I)
      M=MI(I)
      XK=(X(K)-XSHIFT)/SCALE
      YK=(Y(K)-YSHIFT)/SCALE
      XM=(X(M)-XSHIFT)/SCALE
      YM=(Y(M)-YSHIFT)/SCALE
c     invert picture
      YK = 479-YK
      YM = 479-YM
      LX=((XK+XM)/2)
      LY=((YK+YM)/2)
      CALL MOVETO  ( XK, YK,  XY)
      DUMMY = LINETO  ( XM, YM)
      if(iwrite.ne.2) go to 998
      call  moveto(lx,ly,xy)
      write(text, '(i3)') i
      call outgtext (text)
  998 if(iwrite.eq.0.or.iwrite.eq.2) go to 3
      call moveto(lx,ly,xy)
      write(text1,'(f7.0)') for(i)
      call outgtext (text1)
   3  CONTINUE
      if(iwrite.ne.2) go to 996
      do 997 i=1,nn
      lx=(x(i)-xshift)/scale
      yk=(y(i)-yshift)/scale
      ly=(479-yk)
      call  moveto(lx,ly,xy)
      write(text, '(i3)') i
      call outgtext (text)
  997 continue
  996 continue
      read(*,*) ixy
      RETURN
      END
