scilab/modules/optimization/src/fortran/n1fc1o.f

   1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
   2 c Copyright (C) INRIA
   3 c
   4 c This file must be used under the terms of the CeCILL.
   5 c This source file is licensed as described in the file COPYING, which
   6 c you should have received as part of this distribution.  The terms
   7 c are also available at
   8 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
   9 c
  10       subroutine n1fc1o(unit,job,i1,i2,i3,i4,i5,d1,d2,d3,d4)
  11 c
  12 c     impression des traces
  13 c
  14       implicit double precision (a-h,o-z)
  15       integer unit,lunit,job,i1,i2,i3,i4,i5(*)
  16       dimension d4(*),d3(*)
  17 c
  18       character*120  buf
  19
  20       lunit=unit
  21 c
  22       buf=' '
  23       goto(11,12,13,14,15,16,17,18,19,20,
  24      &     21,22,23,24,25,26,27,28,29,30,
  25      &     31,32,33,34,35,36,37,38,39,40,
  26      &     41,42,43,44,45,46,47,48,49,50,
  27      &     51,52,53,54,55,56,57,58,59,60) job
  28 c
  29  11   continue
  30       call basout(io,lunit,'n1fc1   incorrect call')
  31       goto 100
  32  12   continue
  33       n=i1
  34       memax=i2
  35       niz=i3
  36       nrz=i4
  37       ndz=i5(1)
  38       write (buf,'(''entry in n1fc1 . n='',i4,'' memax='',i3)')  n,memax
  39       call basout(io,lunit,buf(1:35))
  40       write (buf,"(a24,i6,a6,i6,a6,i6,a1)")
  41      &     "minimal array sizes: iz(", niz,
  42      &     ")  rz(", nrz,
  43      &     ")  dz(", ndz,
  44      &     ")"
  45       call basout(io,lunit,buf(1:55))
  46       goto 100
  47  13   continue
  48       call basout(io,lunit,'n1fc1 initial gradient norm is zero')
  49       goto 100
  50  14   continue
  51  1000 format (19h n1fc1   iter  nsim,6x,2hfn,11x,3heps,7x,2hs2,
  52      19x,1hu,5x,2hnv)
  53       goto 100
  54  15   continue
  55       iter=i1
  56       write(buf,'(''n1fc1    end with iter ='',i1)') i1
  57       call basout(io,lunit,buf(1:30))
  58       goto 100
  59  16   continue
  60       call  basout(io,lunit,'n1fc1      Incorrect end of fprf2')
  61       goto 100
  62  17   continue
  63       eta2=d1
  64       write(buf,'(''n1fc1   eta2 assigned to '',d10.3)') eta2
  65       call basout(io,lunit,buf(1:35))
  66       goto 100
  67  18   continue
  68       iter=i1
  69       nsim=i2
  70       fn=d1
  71       epsm=d2
  72       s2=d3(1)
  73       write (buf,1018) iter,nsim,fn,epsm,s2
  74  1018 format(6h n1fc1,i7,i5,d16.7,16h   convergence a,d10.3,5h pres,
  75      13h  (,d9.2,1h))
  76       call basout(io,lunit,buf(1:lnblnk(buf)))
  77       goto 100
  78  19   continue
  79       call basout(io,lunit,'n1fc1   normal end')
  80       goto 100
  81  20   continue
  82       call basout(io,lunit,' ')
  83       goto 100
  84  21   continue
  85       iter=i1
  86       nsim=i2
  87       nv=i3
  88       fn=d1
  89       eps=d2
  90       s2=d3(1)
  91       u=d4(1)
  92       write (buf,'(''n1fc1   '',1i4,i5,2x,d14.7,3d10.2,i3)') iter,
  93      $     nsim,fn,eps,s2,u,nv
  94       call basout(io,lunit,buf(1:lnblnk(buf)))
  95       goto 100
  96  22   continue
  97       ntot=i1
  98       call basout(io,lunit,'n1fc1  ponderation table')
  99       nn=ntot/7
 100       if(7*nn.lt.ntot) nn=nn+1
 101       l=0
 102       do 2201 i=1,nn
 103          ln=min(7,ntot-l)
 104          write (buf,'(7x,7d10.3)') (d4(l+j),j=1,ln)
 105          call basout(io,lunit,buf(1:lnblnk(buf)))
 106          l=l+7
 107  2201 continue
 108  23   continue
 109       call basout(io,lunit,'n1fc1  la direction ne pivote plus')
 110       goto 100
 111  24   continue
 112       call basout(io,lunit,'n1fc1  end (dxmin reached)')
 113       goto 100
 114  25   continue
 115       call basout(io,lunit,'n1fc1  end (nsim reached)')
 116       goto 100
 117  26   continue
 118       call basout(io,lunit,'n1fc1  end (indic=0)')
 119       goto 100
 120  27   continue
 121       call basout(io,lunit,'n1fc1  warning txmax reached, reduce scale')
 122       goto 100
 123  28   continue
 124       diam1=d1
 125       eta2=d2
 126       ap=d3(1)
 127       write (buf,2801) diam1,eta2,ap
 128  2801 format (6h n1fc1,12x,6hdiam1=,d10.3,4x,5heta2=,d10.3,4x,
 129      1 3hap=,d10.3)
 130       call basout(io,lunit,buf(1:lnblnk(buf)))
 131       goto 100
 132  29   continue
 133       iter=i1
 134       nsim=i2
 135       ntot=i3
 136       fn=d1
 137       write (buf,2901) iter,nsim,fn,ntot
 138  2901 format(6h n1fc1,i7,i5,d16.7,20h   faisceau reduit a,
 139      1 i3,10h gradients)
 140       call basout(io,lunit,buf(1:lnblnk(buf)))
 141       goto 100
 142  30   continue
 143       logic=i1
 144       ro=d1
 145       tps=d2
 146       tnc=d3(1)
 147       write (buf,3001) logic,ro,tps,tnc
 148  3001 format (6h n1fc1,10x,6hlogic=,i2,4x,3hro=,d10.3,
 149      1 4x,4htps=,d10.3,4x,4htnc=,d10.3)
 150       call basout(io,lunit,buf(1:lnblnk(buf)))
 151       goto 100
 152 c     ==================
 153 c     MESSAGES de frepf2
 154 c     ==================
 155  31   continue
 156       nt1=i1
 157       mm1=i2
 158       deps=d1
 159       call basout(io,lunit,'a = ')
 160       nn=nt1/10
 161       if(10*nn.lt.nt1) nn=nn+1
 162       l=0
 163       do 3101 i=1,nn
 164          ln=min(10,nt1-l)
 165          write (buf,'(6x,10d10.3)') (d3(l+j),j=1,ln)
 166          call basout(io,lunit,buf(1:lnblnk(buf)))
 167          l=l+10
 168  3101 continue
 169       write(buf,'(''    epsilon ='',d10.3)') deps
 170       call basout(io,lunit,buf(1:lnblnk(buf)))
 171
 172       call basout(io,lunit,'(g,g) = ')
 173       do 3103 j=1,nt1
 174          mej=(j-1)*mm1
 175          nn=j/10
 176          if(10*nn.lt.j) nn=nn+1
 177          l=0
 178          do 3102 i=1,nn
 179             ln=min(10,j-l)
 180             write (buf,'(6x,10d10.3)') (d4(mej+l+jj),jj=1,ln)
 181             call basout(io,lunit,buf(1:lnblnk(buf)))
 182             l=l+10
 183  3102    continue
 184  3103 continue
 185       goto 100
 186  32   continue
 187       nv=i1
 188       call basout(io,lunit,'       initial corral')
 189       write(buf,'(20i6)') (i5(k),k=1,nv)
 190       call basout(io,lunit,buf(1:lnblnk(buf)))
 191       goto 100
 192  33   continue
 193       call basout(io,lunit,
 194      $     ' error from fprf2. old solution already optimal')
 195       goto 100
 196  34   continue
 197       call basout(io,lunit,'     epsilon smaller than a')
 198       goto 100
 199  35   continue
 200       j=i1
 201       write(buf,'('' start with variables 1 and,'',i4)') j
 202       call basout(io,lunit,buf(1:lnblnk(buf)))
 203       goto 100
 204  36   continue
 205       nv=i1
 206       call basout(io,lunit,'x = ')
 207       nn=nv/10
 208       if(10*nn.lt.nv) nn=nn+1
 209       l=0
 210       do 3601 i=1,nn
 211          ln=min(10,nv-l)
 212          write (buf,'(3x,10d10.3)') (d4(l+j),j=1,ln)
 213          call basout(io,lunit,buf(1:lnblnk(buf)))
 214          l=l+10
 215  3601 continue
 216       goto 100
 217  37   continue
 218       call basout(io,lunit,' fprf2 is apparently looping')
 219       goto 100
 220  38   continue
 221       j0=i1
 222       s2=d1
 223       sp=d2
 224       write(buf,3801) s2,j0,sp
 225  3801 format(7h (s,s)=,d12.4,10h  variable,i4,
 226      &2h (,d12.4,12h) coming in.)
 227       call basout(io,lunit,buf(1:lnblnk(buf)))
 228       goto 100
 229  39   continue
 230       s2=d1
 231       u1=d2
 232       write(buf,3901) s2,u1
 233  3901 format(7h (s,s)=,d12.4,5h  u1=,d12.3,23h  variable 1 coming in.)
 234       call basout(io,lunit,buf(1:lnblnk(buf)))
 235       goto 100
 236  40   continue
 237       write(buf,'(''   duplicate variable '',i3)') j0
 238       call basout(io,lunit,buf(1:lnblnk(buf)))
 239       goto 100
 240  41   continue
 241       nv=i1
 242       mm1=i2
 243 c     d3=rr,d4=r
 244       write(buf,'(''cholesky '',d11.3)') d3(1)
 245       call basout(io,lunit,buf(1:lnblnk(buf)))
 246       if(nv.ge.2) then
 247          do 4103 ll=2,nv
 248             k1=ll-1
 249             nn=k1/10
 250             if(10*nn.lt.k1) nn=nn+1
 251             l=0
 252             if(nn.gt.1) then
 253             do 4102 i=1,nn-1
 254                ln=min(10,k1-l)
 255                write (buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn)
 256                call basout(io,lunit,buf(1:lnblnk(buf)))
 257                l=l+10
 258  4102       continue
 259             endif
 260             write(buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn),
 261      $           d3(ll)
 262             call basout(io,lunit,buf(1:lnblnk(buf)))
 263  4103    continue
 264       endif
 265       goto 100
 266  42   continue
 267       k0=i1
 268       l=i2
 269       yk0=d1
 270       ps1=d2
 271       ps2=d3(1)
 272       write(buf,4201) k0,l,yk0,ps1,ps2
 273  4201 format(9h variable,i4,2h (,i4,3h) =,d11.3,11h going out.,
 274      & 17h  feasible (s,s)=,d11.4,12h unfeasible=,d11.4)
 275       call basout(io,lunit,buf(1:lnblnk(buf)))
 276       goto 100
 277  43   continue
 278       goto 100
 279  44   continue
 280       nc=i1
 281       nv=i2
 282 c     jc=i5
 283       s2=d1
 284       sp=d2
 285       u1=d3(1)
 286       write(buf,4401) nc,nv,s2,sp,u1
 287  4401 format(14h finished with,i3,10h gradients,i3,
 288      &11h variables./
 289      & 7h (s,s)=,d11.4,6h test=,d11.4/
 290      &               32h cost of the extra constraint u=,d12.5)
 291       nn=nv/20
 292       if(10*nn.lt.nv) nn=nn+1
 293       l=0
 294       do 4402 i=1,nn
 295          ln=min(20,nv-l)
 296          write (buf,'(20i6)') (i5(l+k),k=1,ln)
 297          call basout(io,lunit,buf(1:lnblnk(buf)))
 298          l=l+20
 299  4402 continue
 300       goto 100
 301 c     ================
 302 c     MESSAGE DE NLIS2
 303 c     ================
 304  45   continue
 305       write (buf,4501)
 306  4501 format (/4x,6h nlis2,10x,17htmin force a tmax)
 307       call basout(io,lunit,buf(1:lnblnk(buf)))
 308       goto 100
 309  46   continue
 310       fpn=d1
 311       tmin=d3(1)
 312       tmax=d4(1)
 313       call basout(io,lunit,' ')
 314       write (buf,4601) fpn,d2,tmin,tmax
 315  4601 format (4x,9h nlis2   ,4x,4hfpn=,d10.3,4h d2=,d9.2,
 316      1 7h  tmin=,d9.2,6h tmax=,d9.2)
 317       call basout(io,lunit,buf(1:lnblnk(buf)))
 318       goto 100
 319  47   continue
 320       call basout(io,lunit,' ')
 321       write(buf,4701) nap
 322  4701 format (4x,6h nlis2,3x,i5,22h simulations atteintes)
 323       call basout(io,lunit,buf(1:lnblnk(buf)))
 324       goto 100
 325  48   continue
 326       call basout(io,lunit,'Stop required by user')
 327       goto 100
 328  49   continue
 329       indic=i1
 330       t=d1
 331       write(buf,4901) t,indic
 332  4901 format (4x,6h nlis2,36x,1hi,d10.3,7h indic=,i3)
 333       call basout(io,lunit,buf(1:lnblnk(buf)))
 334       goto 100
 335  50   continue
 336       t=d1
 337       ffn=d2
 338       fp=d3(1)
 339       write(buf,5001) t,ffn,fp
 340  5001 format (4x,6h nlis2,36x,1hi,d10.3,2d11.3)
 341       call basout(io,lunit,buf(1:lnblnk(buf)))
 342       goto 100
 343
 344  51   continue
 345       write(buf,5101) t,ffn,fp
 346  5101 format (4x,6h nlis2,d13.3,2d11.3,2h i)
 347       call basout(io,lunit,buf(1:lnblnk(buf)))
 348       goto 100
 349  52   continue
 350       logic=i1
 351       write(buf,5201) logic
 352  5201 format (4x,6h nlis2,3x,20hcontrainte implicite,i4,7h active)
 353       call basout(io,lunit,buf(1:lnblnk(buf)))
 354       goto 100
 355  53   continue
 356       logic=i1
 357       call basout(io,lunit,'nlis2   end (tmin reached)')
 358       goto 100
 359  54   continue
 360       goto 100
 361  55   continue
 362       goto 100
 363  56   continue
 364       goto 100
 365  57   continue
 366       goto 100
 367  58   continue
 368       goto 100
 369  59   continue
 370       goto 100
 371  60   continue
 372       goto 100
 373 c
 374  100  return
 375       end