Bug in the format.
[scilab.git] / 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
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