1;;; Compiled by f2cl version:
2;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 toy $"
3;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
4;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
5;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
6;;;  "f2cl5.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $"
7;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
8;;;  "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $")
9
10;;; Using Lisp CMU Common Lisp 20d (20D Unicode)
11;;;
12;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
13;;;           (:coerce-assigns :as-needed) (:array-type ':array)
14;;;           (:array-slicing t) (:declare-common nil)
15;;;           (:float-format double-float))
16
17(in-package :lapack)
18
19
20(let* ((cbias 1.5)
21       (zero 0.0)
22       (half 0.5)
23       (one 1.0)
24       (two 2.0)
25       (four 4.0)
26       (hundrd 100.0))
27  (declare (type (double-float 1.5 1.5) cbias)
28           (type (double-float 0.0 0.0) zero)
29           (type (double-float 0.5 0.5) half)
30           (type (double-float 1.0 1.0) one)
31           (type (double-float 2.0 2.0) two)
32           (type (double-float 4.0 4.0) four)
33           (type (double-float 100.0 100.0) hundrd)
34           (ignorable cbias zero half one two four hundrd))
35  (defun dlasq2 (n z info)
36    (declare (type (array double-float (*)) z)
37             (type (f2cl-lib:integer4) info n))
38    (f2cl-lib:with-multi-array-data
39        ((z double-float z-%data% z-%offset%))
40      (prog ((d 0.0) (desig 0.0) (dmin 0.0) (e 0.0) (emax 0.0) (emin 0.0)
41             (eps 0.0) (oldemn 0.0) (qmax 0.0) (qmin 0.0) (s 0.0) (safmin 0.0)
42             (sigma 0.0) (t$ 0.0) (temp 0.0) (tol 0.0) (tol2 0.0) (trace$ 0.0)
43             (zmax 0.0) (i0 0) (i4 0) (iinfo 0) (ipn4 0) (iter 0) (iwhila 0)
44             (iwhilb 0) (k 0) (n0 0) (nbig 0) (ndiv 0) (nfail 0) (pp 0)
45             (splt 0) (ieee nil))
46        (declare (type (double-float) d desig dmin e emax emin eps oldemn qmax
47                                      qmin s safmin sigma t$ temp tol tol2
48                                      trace$ zmax)
49                 (type (f2cl-lib:integer4) i0 i4 iinfo ipn4 iter iwhila iwhilb
50                                           k n0 nbig ndiv nfail pp splt)
51                 (type f2cl-lib:logical ieee))
52        (setf info 0)
53        (setf eps (dlamch "Precision"))
54        (setf safmin (dlamch "Safe minimum"))
55        (setf tol (* eps hundrd))
56        (setf tol2 (expt tol 2))
57        (cond
58          ((< n 0)
59           (setf info -1)
60           (xerbla "DLASQ2" 1)
61           (go end_label))
62          ((= n 0)
63           (go end_label))
64          ((= n 1)
65           (cond
66             ((< (f2cl-lib:fref z (1) ((1 *))) zero)
67              (setf info -201)
68              (xerbla "DLASQ2" 2)))
69           (go end_label))
70          ((= n 2)
71           (cond
72             ((or (< (f2cl-lib:fref z (2) ((1 *))) zero)
73                  (< (f2cl-lib:fref z (3) ((1 *))) zero))
74              (setf info -2)
75              (xerbla "DLASQ2" 2)
76              (go end_label))
77             ((> (f2cl-lib:fref z (3) ((1 *))) (f2cl-lib:fref z (1) ((1 *))))
78              (setf d (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%))
79              (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
80                      (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))
81              (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) d)))
82           (setf (f2cl-lib:fref z-%data% (5) ((1 *)) z-%offset%)
83                   (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)
84                      (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
85                      (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)))
86           (cond
87             ((> (f2cl-lib:fref z (2) ((1 *)))
88                 (* (f2cl-lib:fref z (3) ((1 *))) tol2))
89              (setf t$
90                      (* half
91                         (+
92                          (- (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)
93                             (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%))
94                          (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%))))
95              (setf s
96                      (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
97                         (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
98                            t$)))
99              (cond
100                ((<= s t$)
101                 (setf s
102                         (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
103                            (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
104                               (* t$
105                                  (+ one (f2cl-lib:fsqrt (+ one (/ s t$)))))))))
106                (t
107                 (setf s
108                         (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
109                            (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
110                               (+ t$
111                                  (* (f2cl-lib:fsqrt t$)
112                                     (f2cl-lib:fsqrt (+ t$ s)))))))))
113              (setf t$
114                      (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)
115                         (+ s (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%))))
116              (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
117                      (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)
118                         (/ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)
119                            t$)))
120              (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) t$)))
121           (setf (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
122                   (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%))
123           (setf (f2cl-lib:fref z-%data% (6) ((1 *)) z-%offset%)
124                   (+ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)
125                      (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)))
126           (go end_label)))
127        (setf (f2cl-lib:fref z-%data%
128                             ((f2cl-lib:int-mul 2 n))
129                             ((1 *))
130                             z-%offset%)
131                zero)
132        (setf emin (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%))
133        (setf qmax zero)
134        (setf zmax zero)
135        (setf d zero)
136        (setf e zero)
137        (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 2))
138                      ((> k
139                          (f2cl-lib:int-mul 2
140                                            (f2cl-lib:int-add n
141                                                              (f2cl-lib:int-sub
142                                                               1))))
143                       nil)
144          (tagbody
145            (cond
146              ((< (f2cl-lib:fref z (k) ((1 *))) zero)
147               (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k)))
148               (xerbla "DLASQ2" 2)
149               (go end_label))
150              ((< (f2cl-lib:fref z ((f2cl-lib:int-add k 1)) ((1 *))) zero)
151               (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k 1)))
152               (xerbla "DLASQ2" 2)
153               (go end_label)))
154            (setf d (+ d (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)))
155            (setf e
156                    (+ e
157                       (f2cl-lib:fref z-%data%
158                                      ((f2cl-lib:int-add k 1))
159                                      ((1 *))
160                                      z-%offset%)))
161            (setf qmax
162                    (max qmax (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)))
163            (setf emin
164                    (min emin
165                         (f2cl-lib:fref z-%data%
166                                        ((f2cl-lib:int-add k 1))
167                                        ((1 *))
168                                        z-%offset%)))
169            (setf zmax
170                    (max qmax
171                         zmax
172                         (f2cl-lib:fref z-%data%
173                                        ((f2cl-lib:int-add k 1))
174                                        ((1 *))
175                                        z-%offset%)))
176           label10))
177        (cond
178          ((<
179            (f2cl-lib:fref z
180                           ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n)
181                                              (f2cl-lib:int-sub 1)))
182                           ((1 *)))
183            zero)
184           (setf info
185                   (f2cl-lib:int-sub
186                    (f2cl-lib:int-sub
187                     (f2cl-lib:int-add 200 (f2cl-lib:int-mul 2 n))
188                     1)))
189           (xerbla "DLASQ2" 2)
190           (go end_label)))
191        (setf d
192                (+ d
193                   (f2cl-lib:fref z-%data%
194                                  ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1))
195                                  ((1 *))
196                                  z-%offset%)))
197        (setf qmax
198                (max qmax
199                     (f2cl-lib:fref z-%data%
200                                    ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n)
201                                                       1))
202                                    ((1 *))
203                                    z-%offset%)))
204        (setf zmax (max qmax zmax))
205        (cond
206          ((= e zero)
207           (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
208                         ((> k n) nil)
209             (tagbody
210               (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)
211                       (f2cl-lib:fref z-%data%
212                                      ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k)
213                                                         1))
214                                      ((1 *))
215                                      z-%offset%))
216              label20))
217           (multiple-value-bind (var-0 var-1 var-2 var-3)
218               (dlasrt "D" n z iinfo)
219             (declare (ignore var-0 var-1 var-2))
220             (setf iinfo var-3))
221           (setf (f2cl-lib:fref z-%data%
222                                ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1))
223                                ((1 *))
224                                z-%offset%)
225                   d)
226           (go end_label)))
227        (setf trace$ (+ d e))
228        (cond
229          ((= trace$ zero)
230           (setf (f2cl-lib:fref z-%data%
231                                ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1))
232                                ((1 *))
233                                z-%offset%)
234                   zero)
235           (go end_label)))
236        (setf ieee
237                (and (= (ilaenv 10 "DLASQ2" "N" 1 2 3 4) 1)
238                     (= (ilaenv 11 "DLASQ2" "N" 1 2 3 4) 1)))
239        (f2cl-lib:fdo (k (f2cl-lib:int-mul 2 n)
240                       (f2cl-lib:int-add k (f2cl-lib:int-sub 2)))
241                      ((> k 2) nil)
242          (tagbody
243            (setf (f2cl-lib:fref z-%data%
244                                 ((f2cl-lib:int-mul 2 k))
245                                 ((1 *))
246                                 z-%offset%)
247                    zero)
248            (setf (f2cl-lib:fref z-%data%
249                                 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 1))
250                                 ((1 *))
251                                 z-%offset%)
252                    (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))
253            (setf (f2cl-lib:fref z-%data%
254                                 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 2))
255                                 ((1 *))
256                                 z-%offset%)
257                    zero)
258            (setf (f2cl-lib:fref z-%data%
259                                 ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 3))
260                                 ((1 *))
261                                 z-%offset%)
262                    (f2cl-lib:fref z-%data%
263                                   ((f2cl-lib:int-sub k 1))
264                                   ((1 *))
265                                   z-%offset%))
266           label30))
267        (setf i0 1)
268        (setf n0 n)
269        (cond
270          ((<
271            (* cbias
272               (f2cl-lib:fref z
273                              ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0)
274                                                 (f2cl-lib:int-sub 3)))
275                              ((1 *))))
276            (f2cl-lib:fref z
277                           ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0)
278                                              (f2cl-lib:int-sub 3)))
279                           ((1 *))))
280           (setf ipn4 (f2cl-lib:int-mul 4 (f2cl-lib:int-add i0 n0)))
281           (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add i4 4))
282                         ((> i4
283                             (f2cl-lib:int-mul 2
284                                               (f2cl-lib:int-add i0
285                                                                 n0
286                                                                 (f2cl-lib:int-sub
287                                                                  1))))
288                          nil)
289             (tagbody
290               (setf temp
291                       (f2cl-lib:fref z-%data%
292                                      ((f2cl-lib:int-sub i4 3))
293                                      ((1 *))
294                                      z-%offset%))
295               (setf (f2cl-lib:fref z-%data%
296                                    ((f2cl-lib:int-sub i4 3))
297                                    ((1 *))
298                                    z-%offset%)
299                       (f2cl-lib:fref z-%data%
300                                      ((f2cl-lib:int-sub ipn4 i4 3))
301                                      ((1 *))
302                                      z-%offset%))
303               (setf (f2cl-lib:fref z-%data%
304                                    ((f2cl-lib:int-sub ipn4 i4 3))
305                                    ((1 *))
306                                    z-%offset%)
307                       temp)
308               (setf temp
309                       (f2cl-lib:fref z-%data%
310                                      ((f2cl-lib:int-sub i4 1))
311                                      ((1 *))
312                                      z-%offset%))
313               (setf (f2cl-lib:fref z-%data%
314                                    ((f2cl-lib:int-sub i4 1))
315                                    ((1 *))
316                                    z-%offset%)
317                       (f2cl-lib:fref z-%data%
318                                      ((f2cl-lib:int-sub ipn4 i4 5))
319                                      ((1 *))
320                                      z-%offset%))
321               (setf (f2cl-lib:fref z-%data%
322                                    ((f2cl-lib:int-sub ipn4 i4 5))
323                                    ((1 *))
324                                    z-%offset%)
325                       temp)
326              label40))))
327        (setf pp 0)
328        (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
329                      ((> k 2) nil)
330          (tagbody
331            (setf d
332                    (f2cl-lib:fref z-%data%
333                                   ((f2cl-lib:int-sub
334                                     (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0)
335                                                       pp)
336                                     3))
337                                   ((1 *))
338                                   z-%offset%))
339            (f2cl-lib:fdo (i4
340                           (f2cl-lib:int-add
341                            (f2cl-lib:int-mul 4
342                                              (f2cl-lib:int-add n0
343                                                                (f2cl-lib:int-sub
344                                                                 1)))
345                            pp)
346                           (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4)))
347                          ((> i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp))
348                           nil)
349              (tagbody
350                (cond
351                  ((<=
352                    (f2cl-lib:fref z
353                                   ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1)))
354                                   ((1 *)))
355                    (* tol2 d))
356                   (setf (f2cl-lib:fref z-%data%
357                                        ((f2cl-lib:int-sub i4 1))
358                                        ((1 *))
359                                        z-%offset%)
360                           (- zero))
361                   (setf d
362                           (f2cl-lib:fref z-%data%
363                                          ((f2cl-lib:int-sub i4 3))
364                                          ((1 *))
365                                          z-%offset%)))
366                  (t
367                   (setf d
368                           (*
369                            (f2cl-lib:fref z-%data%
370                                           ((f2cl-lib:int-sub i4 3))
371                                           ((1 *))
372                                           z-%offset%)
373                            (/ d
374                               (+ d
375                                  (f2cl-lib:fref z-%data%
376                                                 ((f2cl-lib:int-sub i4 1))
377                                                 ((1 *))
378                                                 z-%offset%)))))))
379               label50))
380            (setf emin
381                    (f2cl-lib:fref z-%data%
382                                   ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0)
383                                                      pp
384                                                      1))
385                                   ((1 *))
386                                   z-%offset%))
387            (setf d
388                    (f2cl-lib:fref z-%data%
389                                   ((f2cl-lib:int-sub
390                                     (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0)
391                                                       pp)
392                                     3))
393                                   ((1 *))
394                                   z-%offset%))
395            (f2cl-lib:fdo (i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp)
396                           (f2cl-lib:int-add i4 4))
397                          ((> i4
398                              (f2cl-lib:int-add
399                               (f2cl-lib:int-mul 4
400                                                 (f2cl-lib:int-add n0
401                                                                   (f2cl-lib:int-sub
402                                                                    1)))
403                               pp))
404                           nil)
405              (tagbody
406                (setf (f2cl-lib:fref z-%data%
407                                     ((f2cl-lib:int-sub
408                                       (f2cl-lib:int-add i4
409                                                         (f2cl-lib:int-mul -1
410                                                                           2
411                                                                           pp))
412                                       2))
413                                     ((1 *))
414                                     z-%offset%)
415                        (+ d
416                           (f2cl-lib:fref z-%data%
417                                          ((f2cl-lib:int-sub i4 1))
418                                          ((1 *))
419                                          z-%offset%)))
420                (cond
421                  ((<=
422                    (f2cl-lib:fref z
423                                   ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1)))
424                                   ((1 *)))
425                    (* tol2 d))
426                   (setf (f2cl-lib:fref z-%data%
427                                        ((f2cl-lib:int-sub i4 1))
428                                        ((1 *))
429                                        z-%offset%)
430                           (- zero))
431                   (setf (f2cl-lib:fref z-%data%
432                                        ((f2cl-lib:int-sub
433                                          (f2cl-lib:int-add i4
434                                                            (f2cl-lib:int-mul
435                                                             -1
436                                                             2
437                                                             pp))
438                                          2))
439                                        ((1 *))
440                                        z-%offset%)
441                           d)
442                   (setf (f2cl-lib:fref z-%data%
443                                        ((f2cl-lib:int-add i4
444                                                           (f2cl-lib:int-mul -1
445                                                                             2
446                                                                             pp)))
447                                        ((1 *))
448                                        z-%offset%)
449                           zero)
450                   (setf d
451                           (f2cl-lib:fref z-%data%
452                                          ((f2cl-lib:int-add i4 1))
453                                          ((1 *))
454                                          z-%offset%)))
455                  ((and
456                    (<
457                     (* safmin
458                        (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *))))
459                     (f2cl-lib:fref z
460                                    ((f2cl-lib:int-add i4
461                                                       (f2cl-lib:int-mul -1
462                                                                         2
463                                                                         pp)
464                                                       (f2cl-lib:int-sub 2)))
465                                    ((1 *))))
466                    (<
467                     (* safmin
468                        (f2cl-lib:fref z
469                                       ((f2cl-lib:int-add i4
470                                                          (f2cl-lib:int-mul -1
471                                                                            2
472                                                                            pp)
473                                                          (f2cl-lib:int-sub
474                                                           2)))
475                                       ((1 *))))
476                     (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *)))))
477                   (setf temp
478                           (/
479                            (f2cl-lib:fref z-%data%
480                                           ((f2cl-lib:int-add i4 1))
481                                           ((1 *))
482                                           z-%offset%)
483                            (f2cl-lib:fref z-%data%
484                                           ((f2cl-lib:int-sub
485                                             (f2cl-lib:int-add i4
486                                                               (f2cl-lib:int-mul
487                                                                -1
488                                                                2
489                                                                pp))
490                                             2))
491                                           ((1 *))
492                                           z-%offset%)))
493                   (setf (f2cl-lib:fref z-%data%
494                                        ((f2cl-lib:int-add i4
495                                                           (f2cl-lib:int-mul -1
496                                                                             2
497                                                                             pp)))
498                                        ((1 *))
499                                        z-%offset%)
500                           (*
501                            (f2cl-lib:fref z-%data%
502                                           ((f2cl-lib:int-sub i4 1))
503                                           ((1 *))
504                                           z-%offset%)
505                            temp))
506                   (setf d (* d temp)))
507                  (t
508                   (setf (f2cl-lib:fref z-%data%
509                                        ((f2cl-lib:int-add i4
510                                                           (f2cl-lib:int-mul -1
511                                                                             2
512                                                                             pp)))
513                                        ((1 *))
514                                        z-%offset%)
515                           (*
516                            (f2cl-lib:fref z-%data%
517                                           ((f2cl-lib:int-add i4 1))
518                                           ((1 *))
519                                           z-%offset%)
520                            (/
521                             (f2cl-lib:fref z-%data%
522                                            ((f2cl-lib:int-sub i4 1))
523                                            ((1 *))
524                                            z-%offset%)
525                             (f2cl-lib:fref z-%data%
526                                            ((f2cl-lib:int-sub
527                                              (f2cl-lib:int-add i4
528                                                                (f2cl-lib:int-mul
529                                                                 -1
530                                                                 2
531                                                                 pp))
532                                              2))
533                                            ((1 *))
534                                            z-%offset%))))
535                   (setf d
536                           (*
537                            (f2cl-lib:fref z-%data%
538                                           ((f2cl-lib:int-add i4 1))
539                                           ((1 *))
540                                           z-%offset%)
541                            (/ d
542                               (f2cl-lib:fref z-%data%
543                                              ((f2cl-lib:int-sub
544                                                (f2cl-lib:int-add i4
545                                                                  (f2cl-lib:int-mul
546                                                                   -1
547                                                                   2
548                                                                   pp))
549                                                2))
550                                              ((1 *))
551                                              z-%offset%))))))
552                (setf emin
553                        (min emin
554                             (f2cl-lib:fref z-%data%
555                                            ((f2cl-lib:int-add i4
556                                                               (f2cl-lib:int-mul
557                                                                -1
558                                                                2
559                                                                pp)))
560                                            ((1 *))
561                                            z-%offset%)))
562               label60))
563            (setf (f2cl-lib:fref z-%data%
564                                 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0)
565                                                    pp
566                                                    2))
567                                 ((1 *))
568                                 z-%offset%)
569                    d)
570            (setf qmax
571                    (f2cl-lib:fref z-%data%
572                                   ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 i0)
573                                                      pp
574                                                      2))
575                                   ((1 *))
576                                   z-%offset%))
577            (f2cl-lib:fdo (i4
578                           (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0)
579                                             (f2cl-lib:int-sub pp)
580                                             2)
581                           (f2cl-lib:int-add i4 4))
582                          ((> i4
583                              (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0)
584                                                (f2cl-lib:int-sub pp)
585                                                (f2cl-lib:int-sub 2)))
586                           nil)
587              (tagbody
588                (setf qmax
589                        (max qmax
590                             (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%)))
591               label70))
592            (setf pp (f2cl-lib:int-sub 1 pp))
593           label80))
594        (setf iter 2)
595        (setf nfail 0)
596        (setf ndiv (f2cl-lib:int-mul 2 (f2cl-lib:int-sub n0 i0)))
597        (f2cl-lib:fdo (iwhila 1 (f2cl-lib:int-add iwhila 1))
598                      ((> iwhila (f2cl-lib:int-add n 1)) nil)
599          (tagbody
600            (if (< n0 1) (go label150))
601            (setf desig zero)
602            (cond
603              ((= n0 n)
604               (setf sigma zero))
605              (t
606               (setf sigma
607                       (-
608                        (f2cl-lib:fref z-%data%
609                                       ((f2cl-lib:int-sub
610                                         (f2cl-lib:int-mul 4 n0)
611                                         1))
612                                       ((1 *))
613                                       z-%offset%)))))
614            (cond
615              ((< sigma zero)
616               (setf info 1)
617               (go end_label)))
618            (setf emax zero)
619            (cond
620              ((> n0 i0)
621               (setf emin
622                       (abs
623                        (f2cl-lib:fref z-%data%
624                                       ((f2cl-lib:int-sub
625                                         (f2cl-lib:int-mul 4 n0)
626                                         5))
627                                       ((1 *))
628                                       z-%offset%))))
629              (t
630               (setf emin zero)))
631            (setf qmin
632                    (f2cl-lib:fref z-%data%
633                                   ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0)
634                                                      3))
635                                   ((1 *))
636                                   z-%offset%))
637            (setf qmax qmin)
638            (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 n0)
639                           (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4)))
640                          ((> i4 8) nil)
641              (tagbody
642                (if
643                 (<=
644                  (f2cl-lib:fref z-%data%
645                                 ((f2cl-lib:int-sub i4 5))
646                                 ((1 *))
647                                 z-%offset%)
648                  zero)
649                 (go label100))
650                (cond
651                  ((>= qmin (* four emax))
652                   (setf qmin
653                           (min qmin
654                                (f2cl-lib:fref z-%data%
655                                               ((f2cl-lib:int-sub i4 3))
656                                               ((1 *))
657                                               z-%offset%)))
658                   (setf emax
659                           (max emax
660                                (f2cl-lib:fref z-%data%
661                                               ((f2cl-lib:int-sub i4 5))
662                                               ((1 *))
663                                               z-%offset%)))))
664                (setf qmax
665                        (max qmax
666                             (+
667                              (f2cl-lib:fref z-%data%
668                                             ((f2cl-lib:int-sub i4 7))
669                                             ((1 *))
670                                             z-%offset%)
671                              (f2cl-lib:fref z-%data%
672                                             ((f2cl-lib:int-sub i4 5))
673                                             ((1 *))
674                                             z-%offset%))))
675                (setf emin
676                        (min emin
677                             (f2cl-lib:fref z-%data%
678                                            ((f2cl-lib:int-sub i4 5))
679                                            ((1 *))
680                                            z-%offset%)))
681               label90))
682            (setf i4 4)
683           label100
684            (setf i0 (the f2cl-lib:integer4 (truncate i4 4)))
685            (setf (f2cl-lib:fref z-%data%
686                                 ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 1))
687                                 ((1 *))
688                                 z-%offset%)
689                    emin)
690            (setf dmin
691                    (-
692                     (max zero
693                          (+ qmin
694                             (* (- two)
695                                (f2cl-lib:fsqrt qmin)
696                                (f2cl-lib:fsqrt emax))))))
697            (setf pp 0)
698            (setf nbig
699                    (f2cl-lib:int-mul 30
700                                      (f2cl-lib:int-add
701                                       (f2cl-lib:int-sub n0 i0)
702                                       1)))
703            (f2cl-lib:fdo (iwhilb 1 (f2cl-lib:int-add iwhilb 1))
704                          ((> iwhilb nbig) nil)
705              (tagbody
706                (if (> i0 n0) (go label130))
707                (multiple-value-bind
708                      (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
709                       var-9 var-10 var-11)
710                    (dlasq3 i0 n0 z pp dmin sigma desig qmax nfail iter ndiv
711                     ieee)
712                  (declare (ignore var-0 var-2 var-3 var-11))
713                  (setf n0 var-1)
714                  (setf dmin var-4)
715                  (setf sigma var-5)
716                  (setf desig var-6)
717                  (setf qmax var-7)
718                  (setf nfail var-8)
719                  (setf iter var-9)
720                  (setf ndiv var-10))
721                (setf pp (f2cl-lib:int-sub 1 pp))
722                (cond
723                  ((and (= pp 0)
724                        (>= (f2cl-lib:int-add n0 (f2cl-lib:int-sub i0)) 3))
725                   (cond
726                     ((or
727                       (<= (f2cl-lib:fref z ((f2cl-lib:int-mul 4 n0)) ((1 *)))
728                           (* tol2 qmax))
729                       (<=
730                        (f2cl-lib:fref z
731                                       ((f2cl-lib:int-add
732                                         (f2cl-lib:int-mul 4 n0)
733                                         (f2cl-lib:int-sub 1)))
734                                       ((1 *)))
735                        (* tol2 sigma)))
736                      (setf splt (f2cl-lib:int-sub i0 1))
737                      (setf qmax
738                              (f2cl-lib:fref z-%data%
739                                             ((f2cl-lib:int-sub
740                                               (f2cl-lib:int-mul 4 i0)
741                                               3))
742                                             ((1 *))
743                                             z-%offset%))
744                      (setf emin
745                              (f2cl-lib:fref z-%data%
746                                             ((f2cl-lib:int-sub
747                                               (f2cl-lib:int-mul 4 i0)
748                                               1))
749                                             ((1 *))
750                                             z-%offset%))
751                      (setf oldemn
752                              (f2cl-lib:fref z-%data%
753                                             ((f2cl-lib:int-mul 4 i0))
754                                             ((1 *))
755                                             z-%offset%))
756                      (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0)
757                                     (f2cl-lib:int-add i4 4))
758                                    ((> i4
759                                        (f2cl-lib:int-mul 4
760                                                          (f2cl-lib:int-add n0
761                                                                            (f2cl-lib:int-sub
762                                                                             3))))
763                                     nil)
764                        (tagbody
765                          (cond
766                            ((or
767                              (<= (f2cl-lib:fref z (i4) ((1 *)))
768                                  (* tol2
769                                     (f2cl-lib:fref z
770                                                    ((f2cl-lib:int-add i4
771                                                                       (f2cl-lib:int-sub
772                                                                        3)))
773                                                    ((1 *)))))
774                              (<=
775                               (f2cl-lib:fref z
776                                              ((f2cl-lib:int-add i4
777                                                                 (f2cl-lib:int-sub
778                                                                  1)))
779                                              ((1 *)))
780                               (* tol2 sigma)))
781                             (setf (f2cl-lib:fref z-%data%
782                                                  ((f2cl-lib:int-sub i4 1))
783                                                  ((1 *))
784                                                  z-%offset%)
785                                     (- sigma))
786                             (setf splt (the f2cl-lib:integer4 (truncate i4 4)))
787                             (setf qmax zero)
788                             (setf emin
789                                     (f2cl-lib:fref z-%data%
790                                                    ((f2cl-lib:int-add i4 3))
791                                                    ((1 *))
792                                                    z-%offset%))
793                             (setf oldemn
794                                     (f2cl-lib:fref z-%data%
795                                                    ((f2cl-lib:int-add i4 4))
796                                                    ((1 *))
797                                                    z-%offset%)))
798                            (t
799                             (setf qmax
800                                     (max qmax
801                                          (f2cl-lib:fref z-%data%
802                                                         ((f2cl-lib:int-add i4
803                                                                            1))
804                                                         ((1 *))
805                                                         z-%offset%)))
806                             (setf emin
807                                     (min emin
808                                          (f2cl-lib:fref z-%data%
809                                                         ((f2cl-lib:int-sub i4
810                                                                            1))
811                                                         ((1 *))
812                                                         z-%offset%)))
813                             (setf oldemn
814                                     (min oldemn
815                                          (f2cl-lib:fref z-%data%
816                                                         (i4)
817                                                         ((1 *))
818                                                         z-%offset%)))))
819                         label110))
820                      (setf (f2cl-lib:fref z-%data%
821                                           ((f2cl-lib:int-sub
822                                             (f2cl-lib:int-mul 4 n0)
823                                             1))
824                                           ((1 *))
825                                           z-%offset%)
826                              emin)
827                      (setf (f2cl-lib:fref z-%data%
828                                           ((f2cl-lib:int-mul 4 n0))
829                                           ((1 *))
830                                           z-%offset%)
831                              oldemn)
832                      (setf i0 (f2cl-lib:int-add splt 1))))))
833               label120))
834            (setf info 2)
835            (go end_label)
836           label130
837           label140))
838        (setf info 3)
839        (go end_label)
840       label150
841        (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
842                      ((> k n) nil)
843          (tagbody
844            (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)
845                    (f2cl-lib:fref z-%data%
846                                   ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 k)
847                                                      3))
848                                   ((1 *))
849                                   z-%offset%))
850           label160))
851        (multiple-value-bind (var-0 var-1 var-2 var-3)
852            (dlasrt "D" n z iinfo)
853          (declare (ignore var-0 var-1 var-2))
854          (setf iinfo var-3))
855        (setf e zero)
856        (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1)))
857                      ((> k 1) nil)
858          (tagbody
859            (setf e (+ e (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)))
860           label170))
861        (setf (f2cl-lib:fref z-%data%
862                             ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 1))
863                             ((1 *))
864                             z-%offset%)
865                trace$)
866        (setf (f2cl-lib:fref z-%data%
867                             ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 2))
868                             ((1 *))
869                             z-%offset%)
870                e)
871        (setf (f2cl-lib:fref z-%data%
872                             ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 3))
873                             ((1 *))
874                             z-%offset%)
875                (f2cl-lib:dble iter))
876        (setf (f2cl-lib:fref z-%data%
877                             ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 4))
878                             ((1 *))
879                             z-%offset%)
880                (/ (f2cl-lib:dble ndiv) (f2cl-lib:dble (expt n 2))))
881        (setf (f2cl-lib:fref z-%data%
882                             ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 5))
883                             ((1 *))
884                             z-%offset%)
885                (/ (* hundrd nfail) (f2cl-lib:dble iter)))
886        (go end_label)
887       end_label
888        (return (values nil nil info))))))
889
890(in-package #-gcl #:cl-user #+gcl "CL-USER")
891#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
892(eval-when (:load-toplevel :compile-toplevel :execute)
893  (setf (gethash 'fortran-to-lisp::dlasq2
894                 fortran-to-lisp::*f2cl-function-info*)
895          (fortran-to-lisp::make-f2cl-finfo
896           :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
897                        (fortran-to-lisp::integer4))
898           :return-values '(nil nil fortran-to-lisp::info)
899           :calls '(fortran-to-lisp::dlasq3 fortran-to-lisp::ilaenv
900                    fortran-to-lisp::dlasrt fortran-to-lisp::xerbla
901                    fortran-to-lisp::dlamch))))
902
903