c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
c Copyright (C) INRIA
c 
c This file must be used under the terms of the CeCILL.
c This source file is licensed as described in the file COPYING, which
c you should have received as part of this distribution.  The terms
c are also available at    
c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt
c
      subroutine n1fc1o(unit,job,i1,i2,i3,i4,i5,d1,d2,d3,d4)
c
c     impression des traces
c
      implicit double precision (a-h,o-z)
      integer unit,lunit,job,i1,i2,i3,i4,i5(*)
      dimension d4(*),d3(*)
c     
      character*120  buf
     
      lunit=unit
c
      buf=' '
      goto(11,12,13,14,15,16,17,18,19,20,
     &     21,22,23,24,25,26,27,28,29,30,
     &     31,32,33,34,35,36,37,38,39,40,
     &     41,42,43,44,45,46,47,48,49,50,
     &     51,52,53,54,55,56,57,58,59,60) job
c
 11   continue
      call basout(io,lunit,'n1fc1   incorrect call')
      goto 100 
 12   continue
      n=i1
      memax=i2
      niz=i3
      nrz=i4
      ndz=i5(1)
      write (buf,'(''entry in n1fc1 . n='',i4,'' memax='',i3)')  n,memax
      call basout(io,lunit,buf(1:35))
      write (buf,"(a24,i6,a6,i6,a6,i6,a1)") 
     &     "minimal array sizes: iz(", niz, 
     &     ")  rz(", nrz, 
     &     ")  dz(", ndz,
     &     ")"
      call basout(io,lunit,buf(1:55))
      goto 100
 13   continue
      call basout(io,lunit,'n1fc1 initial gradient norm is zero')
      goto 100
 14   continue
 1000 format (19h n1fc1   iter  nsim,6x,2hfn,11x,3heps,7x,2hs2,
     19x,1hu,5x,2hnv)
      goto 100
 15   continue
      iter=i1
      write(buf,'(''n1fc1    end with iter ='',i1)') i1
      call basout(io,lunit,buf(1:30))
      goto 100
 16   continue
      call  basout(io,lunit,'n1fc1      Incorrect end of fprf2')
      goto 100
 17   continue
      eta2=d1
      write(buf,'(''n1fc1   eta2 assigned to '',d10.3)') eta2
      call basout(io,lunit,buf(1:35))
      goto 100
 18   continue
      iter=i1
      nsim=i2
      fn=d1
      epsm=d2
      s2=d3(1)
      write (buf,1018) iter,nsim,fn,epsm,s2
 1018 format(6h n1fc1,i7,i5,d16.7,16h   convergence a,d10.3,5h pres,
     13h  (,d9.2,1h))
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 19   continue
      call basout(io,lunit,'n1fc1   normal end')
      goto 100
 20   continue
      call basout(io,lunit,' ')
      goto 100
 21   continue
      iter=i1
      nsim=i2
      nv=i3
      fn=d1
      eps=d2
      s2=d3(1)
      u=d4(1)
      write (buf,'(''n1fc1   '',1i4,i5,2x,d14.7,3d10.2,i3)') iter,
     $     nsim,fn,eps,s2,u,nv 
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100 
 22   continue
      ntot=i1
      call basout(io,lunit,'n1fc1  ponderation table')
      nn=ntot/7
      if(7*nn.lt.ntot) nn=nn+1
      l=0
      do 2201 i=1,nn
         ln=min(7,ntot-l)
         write (buf,'(7x,7d10.3)') (d4(l+j),j=1,ln)
         call basout(io,lunit,buf(1:lnblnk(buf)))
         l=l+7
 2201 continue
 23   continue
      call basout(io,lunit,'n1fc1  la direction ne pivote plus')
      goto 100
 24   continue
      call basout(io,lunit,'n1fc1  end (dxmin reached)')
      goto 100
 25   continue
      call basout(io,lunit,'n1fc1  end (nsim reached)')
      goto 100
 26   continue
      call basout(io,lunit,'n1fc1  end (indic=0)')
      goto 100
 27   continue
      call basout(io,lunit,'n1fc1  warning txmax reached, reduce scale')
      goto 100
 28   continue
      diam1=d1
      eta2=d2
      ap=d3(1)
      write (buf,2801) diam1,eta2,ap
 2801 format (6h n1fc1,12x,6hdiam1=,d10.3,4x,5heta2=,d10.3,4x,
     1 3hap=,d10.3)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 29   continue
      iter=i1
      nsim=i2
      ntot=i3
      fn=d1
      write (buf,2901) iter,nsim,fn,ntot
 2901 format(6h n1fc1,i7,i5,d16.7,20h   faisceau reduit a,
     1 i3,10h gradients)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 30   continue
      logic=i1
      ro=d1
      tps=d2
      tnc=d3(1)
      write (buf,3001) logic,ro,tps,tnc
 3001 format (6h n1fc1,10x,6hlogic=,i2,4x,3hro=,d10.3,
     1 4x,4htps=,d10.3,4x,4htnc=,d10.3)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
c     ==================
c     MESSAGES de frepf2
c     ==================
 31   continue
      nt1=i1
      mm1=i2
      deps=d1
      call basout(io,lunit,'a = ')
      nn=nt1/10
      if(10*nn.lt.nt1) nn=nn+1
      l=0
      do 3101 i=1,nn
         ln=min(10,nt1-l)
         write (buf,'(6x,10d10.3)') (d3(l+j),j=1,ln)
         call basout(io,lunit,buf(1:lnblnk(buf)))
         l=l+10
 3101 continue
      write(buf,'(''    epsilon ='',d10.3)') deps
      call basout(io,lunit,buf(1:lnblnk(buf)))

      call basout(io,lunit,'(g,g) = ')
      do 3103 j=1,nt1
         mej=(j-1)*mm1
         nn=j/10
         if(10*nn.lt.j) nn=nn+1
         l=0
         do 3102 i=1,nn
            ln=min(10,j-l)
            write (buf,'(6x,10d10.3)') (d4(mej+l+jj),jj=1,ln)
            call basout(io,lunit,buf(1:lnblnk(buf)))
            l=l+10
 3102    continue
 3103 continue
      goto 100
 32   continue
      nv=i1
      call basout(io,lunit,'       initial corral')
      write(buf,'(20i6)') (i5(k),k=1,nv)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 33   continue
      call basout(io,lunit,
     $     ' error from fprf2. old solution already optimal')
      goto 100
 34   continue
      call basout(io,lunit,'     epsilon smaller than a')
      goto 100
 35   continue
      j=i1
      write(buf,'('' start with variables 1 and,'',i4)') j
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 36   continue
      nv=i1
      call basout(io,lunit,'x = ')
      nn=nv/10
      if(10*nn.lt.nv) nn=nn+1
      l=0
      do 3601 i=1,nn
         ln=min(10,nv-l)
         write (buf,'(3x,10d10.3)') (d4(l+j),j=1,ln)
         call basout(io,lunit,buf(1:lnblnk(buf)))
         l=l+10
 3601 continue
      goto 100
 37   continue
      call basout(io,lunit,' fprf2 is apparently looping')
      goto 100
 38   continue
      j0=i1
      s2=d1
      sp=d2
      write(buf,3801) s2,j0,sp
 3801 format(7h (s,s)=,d12.4,10h  variable,i4,
     &2h (,d12.4,12h) coming in.)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 39   continue
      s2=d1
      u1=d2
      write(buf,3901) s2,u1
 3901 format(7h (s,s)=,d12.4,5h  u1=,d12.3,23h  variable 1 coming in.)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 40   continue
      write(buf,'(''   duplicate variable '',i3)') j0
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 41   continue
      nv=i1
      mm1=i2
c     d3=rr,d4=r
      write(buf,'(''cholesky '',d11.3)') d3(1)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      if(nv.ge.2) then
         do 4103 ll=2,nv
            k1=ll-1
            nn=k1/10
            if(10*nn.lt.k1) nn=nn+1
            l=0
            if(nn.gt.1) then
            do 4102 i=1,nn-1
               ln=min(10,k1-l)
               write (buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn)
               call basout(io,lunit,buf(1:lnblnk(buf)))
               l=l+10
 4102       continue
            endif
            write(buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn),
     $           d3(ll)
            call basout(io,lunit,buf(1:lnblnk(buf)))
 4103    continue
      endif
      goto 100
 42   continue
      k0=i1
      l=i2
      yk0=d1
      ps1=d2
      ps2=d3(1)
      write(buf,4201) k0,l,yk0,ps1,ps2
 4201 format(9h variable,i4,2h (,i4,3h) =,d11.3,11h going out.,
     & 17h  feasible (s,s)=,d11.4,12h unfeasible=,d11.4)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 43   continue
      goto 100
 44   continue
      nc=i1
      nv=i2
c     jc=i5
      s2=d1
      sp=d2
      u1=d3(1)
      write(buf,4401) nc,nv
      call basout(io,lunit,buf(1:lnblnk(buf)))
      
      write(buf,44010)
      call basout(io,lunit,buf(1:lnblnk(buf)))

      write(buf,44011) s2,sp
      call basout(io,lunit,buf(1:lnblnk(buf)))      
      
      write(buf,44012) u1
      call basout(io,lunit,buf(1:lnblnk(buf)))
      
 4401     format(14h finished with,i3,10h gradients,i3)
44010     format(11h variables.)
44011     format(7h (s,s)=,d11.4,6h test=,d11.4)
44012     format(32h cost of the extra constraint u=,d12.5)
      
      nn=nv/20
      if(10*nn.lt.nv) nn=nn+1
      l=0
      do 4402 i=1,nn
         ln=min(20,nv-l)
         write (buf,'(20i6)') (i5(l+k),k=1,ln)
         call basout(io,lunit,buf(1:lnblnk(buf)))
         l=l+20
 4402 continue
      goto 100
c     ================
c     MESSAGE DE NLIS2
c     ================
 45   continue
      write (buf,4501)
 4501 format (4x,6h nlis2,10x,17htmin force a tmax)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 46   continue
      fpn=d1
      tmin=d3(1)
      tmax=d4(1)
      call basout(io,lunit,' ')
      write (buf,4601) fpn,d2,tmin,tmax
 4601 format (4x,9h nlis2   ,4x,4hfpn=,d10.3,4h d2=,d9.2,
     1 7h  tmin=,d9.2,6h tmax=,d9.2)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 47   continue
      call basout(io,lunit,' ')
      write(buf,4701) nap
 4701 format (4x,6h nlis2,3x,i5,22h simulations atteintes)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 48   continue
      call basout(io,lunit,'Stop required by user')
      goto 100
 49   continue
      indic=i1
      t=d1
      write(buf,4901) t,indic
 4901 format (4x,6h nlis2,36x,1hi,d10.3,7h indic=,i3)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 50   continue
      t=d1
      ffn=d2
      fp=d3(1)
      write(buf,5001) t,ffn,fp
 5001 format (4x,6h nlis2,36x,1hi,d10.3,2d11.3)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100

 51   continue
      write(buf,5101) t,ffn,fp
 5101 format (4x,6h nlis2,d13.3,2d11.3,2h i)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 52   continue
      logic=i1
      write(buf,5201) logic
 5201 format (4x,6h nlis2,3x,20hcontrainte implicite,i4,7h active)
      call basout(io,lunit,buf(1:lnblnk(buf)))
      goto 100
 53   continue
      logic=i1
      call basout(io,lunit,'nlis2   end (tmin reached)')
      goto 100
 54   continue
      goto 100
 55   continue
      goto 100
 56   continue
      goto 100
 57   continue
      goto 100
 58   continue
      goto 100
 59   continue
      goto 100
 60   continue
      goto 100
c
 100  return
      end
