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(defun ilaenv (ispec name opts n1 n2 n3 n4)
21  (declare (type (simple-string *) opts name)
22           (type (f2cl-lib:integer4) n4 n3 n2 n1 ispec))
23  (f2cl-lib:with-multi-array-data
24      ((name character name-%data% name-%offset%)
25       (opts character opts-%data% opts-%offset%))
26    (prog ((i 0) (ic 0) (iz 0) (nb 0) (nbmin 0) (nx 0)
27           (subnam
28            (make-array '(6) :element-type 'character :initial-element #\ ))
29           (c3 (make-array '(3) :element-type 'character :initial-element #\ ))
30           (c2 (make-array '(2) :element-type 'character :initial-element #\ ))
31           (c4 (make-array '(2) :element-type 'character :initial-element #\ ))
32           (c1 (make-array '(1) :element-type 'character :initial-element #\ ))
33           (cname nil) (sname nil) (ilaenv 0))
34      (declare (type f2cl-lib:logical sname cname)
35               (type (simple-string 1) c1)
36               (type (simple-string 2) c4 c2)
37               (type (simple-string 3) c3)
38               (type (simple-string 6) subnam)
39               (type (f2cl-lib:integer4) ilaenv nx nbmin nb iz ic i))
40      (f2cl-lib:computed-goto
41       (label100 label100 label100 label400 label500 label600 label700 label800
42        label900 label1000 label1100)
43       ispec)
44      (setf ilaenv -1)
45      (go end_label)
46     label100
47      (setf ilaenv 1)
48      (f2cl-lib:f2cl-set-string subnam name (string 6))
49      (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (1 1))))
50      (setf iz (f2cl-lib:ichar "Z"))
51      (cond
52        ((or (= iz 90) (= iz 122))
53         (cond
54           ((and (>= ic 97) (<= ic 122))
55            (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1))
56                                  (f2cl-lib:fchar (f2cl-lib:int-sub ic 32)))
57            (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
58                          ((> i 6) nil)
59              (tagbody
60                (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i))))
61                (if (and (>= ic 97) (<= ic 122))
62                    (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i))
63                                          (f2cl-lib:fchar
64                                           (f2cl-lib:int-sub ic 32))))
65               label10)))))
66        ((or (= iz 233) (= iz 169))
67         (cond
68           ((or (and (>= ic 129) (<= ic 137))
69                (and (>= ic 145) (<= ic 153))
70                (and (>= ic 162) (<= ic 169)))
71            (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1))
72                                  (f2cl-lib:fchar (f2cl-lib:int-add ic 64)))
73            (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
74                          ((> i 6) nil)
75              (tagbody
76                (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i))))
77                (if
78                 (or (and (>= ic 129) (<= ic 137))
79                     (and (>= ic 145) (<= ic 153))
80                     (and (>= ic 162) (<= ic 169)))
81                 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i))
82                                       (f2cl-lib:fchar
83                                        (f2cl-lib:int-add ic 64))))
84               label20)))))
85        ((or (= iz 218) (= iz 250))
86         (cond
87           ((and (>= ic 225) (<= ic 250))
88            (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1))
89                                  (f2cl-lib:fchar (f2cl-lib:int-sub ic 32)))
90            (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
91                          ((> i 6) nil)
92              (tagbody
93                (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i))))
94                (if (and (>= ic 225) (<= ic 250))
95                    (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i))
96                                          (f2cl-lib:fchar
97                                           (f2cl-lib:int-sub ic 32))))
98               label30))))))
99      (f2cl-lib:f2cl-set-string c1
100                                (f2cl-lib:fref-string subnam (1 1))
101                                (string 1))
102      (setf sname (or (f2cl-lib:fstring-= c1 "S") (f2cl-lib:fstring-= c1 "D")))
103      (setf cname (or (f2cl-lib:fstring-= c1 "C") (f2cl-lib:fstring-= c1 "Z")))
104      (if (not (or cname sname)) (go end_label))
105      (f2cl-lib:f2cl-set-string c2
106                                (f2cl-lib:fref-string subnam (2 3))
107                                (string 2))
108      (f2cl-lib:f2cl-set-string c3
109                                (f2cl-lib:fref-string subnam (4 6))
110                                (string 3))
111      (f2cl-lib:f2cl-set-string c4 (f2cl-lib:fref-string c3 (2 3)) (string 2))
112      (f2cl-lib:computed-goto (label110 label200 label300) ispec)
113     label110
114      (setf nb 1)
115      (cond
116        ((f2cl-lib:fstring-= c2 "GE")
117         (cond
118           ((f2cl-lib:fstring-= c3 "TRF")
119            (cond
120              (sname
121               (setf nb 64))
122              (t
123               (setf nb 64))))
124           ((or (f2cl-lib:fstring-= c3 "QRF")
125                (f2cl-lib:fstring-= c3 "RQF")
126                (f2cl-lib:fstring-= c3 "LQF")
127                (f2cl-lib:fstring-= c3 "QLF"))
128            (cond
129              (sname
130               (setf nb 32))
131              (t
132               (setf nb 32))))
133           ((f2cl-lib:fstring-= c3 "HRD")
134            (cond
135              (sname
136               (setf nb 32))
137              (t
138               (setf nb 32))))
139           ((f2cl-lib:fstring-= c3 "BRD")
140            (cond
141              (sname
142               (setf nb 32))
143              (t
144               (setf nb 32))))
145           ((f2cl-lib:fstring-= c3 "TRI")
146            (cond
147              (sname
148               (setf nb 64))
149              (t
150               (setf nb 64))))))
151        ((f2cl-lib:fstring-= c2 "PO")
152         (cond
153           ((f2cl-lib:fstring-= c3 "TRF")
154            (cond
155              (sname
156               (setf nb 64))
157              (t
158               (setf nb 64))))))
159        ((f2cl-lib:fstring-= c2 "SY")
160         (cond
161           ((f2cl-lib:fstring-= c3 "TRF")
162            (cond
163              (sname
164               (setf nb 64))
165              (t
166               (setf nb 64))))
167           ((and sname (f2cl-lib:fstring-= c3 "TRD"))
168            (setf nb 32))
169           ((and sname (f2cl-lib:fstring-= c3 "GST"))
170            (setf nb 64))))
171        ((and cname (f2cl-lib:fstring-= c2 "HE"))
172         (cond
173           ((f2cl-lib:fstring-= c3 "TRF")
174            (setf nb 64))
175           ((f2cl-lib:fstring-= c3 "TRD")
176            (setf nb 32))
177           ((f2cl-lib:fstring-= c3 "GST")
178            (setf nb 64))))
179        ((and sname (f2cl-lib:fstring-= c2 "OR"))
180         (cond
181           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
182            (cond
183              ((or (f2cl-lib:fstring-= c4 "QR")
184                   (f2cl-lib:fstring-= c4 "RQ")
185                   (f2cl-lib:fstring-= c4 "LQ")
186                   (f2cl-lib:fstring-= c4 "QL")
187                   (f2cl-lib:fstring-= c4 "HR")
188                   (f2cl-lib:fstring-= c4 "TR")
189                   (f2cl-lib:fstring-= c4 "BR"))
190               (setf nb 32))))
191           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M")
192            (cond
193              ((or (f2cl-lib:fstring-= c4 "QR")
194                   (f2cl-lib:fstring-= c4 "RQ")
195                   (f2cl-lib:fstring-= c4 "LQ")
196                   (f2cl-lib:fstring-= c4 "QL")
197                   (f2cl-lib:fstring-= c4 "HR")
198                   (f2cl-lib:fstring-= c4 "TR")
199                   (f2cl-lib:fstring-= c4 "BR"))
200               (setf nb 32))))))
201        ((and cname (f2cl-lib:fstring-= c2 "UN"))
202         (cond
203           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
204            (cond
205              ((or (f2cl-lib:fstring-= c4 "QR")
206                   (f2cl-lib:fstring-= c4 "RQ")
207                   (f2cl-lib:fstring-= c4 "LQ")
208                   (f2cl-lib:fstring-= c4 "QL")
209                   (f2cl-lib:fstring-= c4 "HR")
210                   (f2cl-lib:fstring-= c4 "TR")
211                   (f2cl-lib:fstring-= c4 "BR"))
212               (setf nb 32))))
213           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M")
214            (cond
215              ((or (f2cl-lib:fstring-= c4 "QR")
216                   (f2cl-lib:fstring-= c4 "RQ")
217                   (f2cl-lib:fstring-= c4 "LQ")
218                   (f2cl-lib:fstring-= c4 "QL")
219                   (f2cl-lib:fstring-= c4 "HR")
220                   (f2cl-lib:fstring-= c4 "TR")
221                   (f2cl-lib:fstring-= c4 "BR"))
222               (setf nb 32))))))
223        ((f2cl-lib:fstring-= c2 "GB")
224         (cond
225           ((f2cl-lib:fstring-= c3 "TRF")
226            (cond
227              (sname
228               (cond
229                 ((<= n4 64)
230                  (setf nb 1))
231                 (t
232                  (setf nb 32))))
233              (t
234               (cond
235                 ((<= n4 64)
236                  (setf nb 1))
237                 (t
238                  (setf nb 32))))))))
239        ((f2cl-lib:fstring-= c2 "PB")
240         (cond
241           ((f2cl-lib:fstring-= c3 "TRF")
242            (cond
243              (sname
244               (cond
245                 ((<= n2 64)
246                  (setf nb 1))
247                 (t
248                  (setf nb 32))))
249              (t
250               (cond
251                 ((<= n2 64)
252                  (setf nb 1))
253                 (t
254                  (setf nb 32))))))))
255        ((f2cl-lib:fstring-= c2 "TR")
256         (cond
257           ((f2cl-lib:fstring-= c3 "TRI")
258            (cond
259              (sname
260               (setf nb 64))
261              (t
262               (setf nb 64))))))
263        ((f2cl-lib:fstring-= c2 "LA")
264         (cond
265           ((f2cl-lib:fstring-= c3 "UUM")
266            (cond
267              (sname
268               (setf nb 64))
269              (t
270               (setf nb 64))))))
271        ((and sname (f2cl-lib:fstring-= c2 "ST"))
272         (cond
273           ((f2cl-lib:fstring-= c3 "EBZ")
274            (setf nb 1)))))
275      (setf ilaenv nb)
276      (go end_label)
277     label200
278      (setf nbmin 2)
279      (cond
280        ((f2cl-lib:fstring-= c2 "GE")
281         (cond
282           ((or (f2cl-lib:fstring-= c3 "QRF")
283                (f2cl-lib:fstring-= c3 "RQF")
284                (f2cl-lib:fstring-= c3 "LQF")
285                (f2cl-lib:fstring-= c3 "QLF"))
286            (cond
287              (sname
288               (setf nbmin 2))
289              (t
290               (setf nbmin 2))))
291           ((f2cl-lib:fstring-= c3 "HRD")
292            (cond
293              (sname
294               (setf nbmin 2))
295              (t
296               (setf nbmin 2))))
297           ((f2cl-lib:fstring-= c3 "BRD")
298            (cond
299              (sname
300               (setf nbmin 2))
301              (t
302               (setf nbmin 2))))
303           ((f2cl-lib:fstring-= c3 "TRI")
304            (cond
305              (sname
306               (setf nbmin 2))
307              (t
308               (setf nbmin 2))))))
309        ((f2cl-lib:fstring-= c2 "SY")
310         (cond
311           ((f2cl-lib:fstring-= c3 "TRF")
312            (cond
313              (sname
314               (setf nbmin 8))
315              (t
316               (setf nbmin 8))))
317           ((and sname (f2cl-lib:fstring-= c3 "TRD"))
318            (setf nbmin 2))))
319        ((and cname (f2cl-lib:fstring-= c2 "HE"))
320         (cond
321           ((f2cl-lib:fstring-= c3 "TRD")
322            (setf nbmin 2))))
323        ((and sname (f2cl-lib:fstring-= c2 "OR"))
324         (cond
325           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
326            (cond
327              ((or (f2cl-lib:fstring-= c4 "QR")
328                   (f2cl-lib:fstring-= c4 "RQ")
329                   (f2cl-lib:fstring-= c4 "LQ")
330                   (f2cl-lib:fstring-= c4 "QL")
331                   (f2cl-lib:fstring-= c4 "HR")
332                   (f2cl-lib:fstring-= c4 "TR")
333                   (f2cl-lib:fstring-= c4 "BR"))
334               (setf nbmin 2))))
335           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M")
336            (cond
337              ((or (f2cl-lib:fstring-= c4 "QR")
338                   (f2cl-lib:fstring-= c4 "RQ")
339                   (f2cl-lib:fstring-= c4 "LQ")
340                   (f2cl-lib:fstring-= c4 "QL")
341                   (f2cl-lib:fstring-= c4 "HR")
342                   (f2cl-lib:fstring-= c4 "TR")
343                   (f2cl-lib:fstring-= c4 "BR"))
344               (setf nbmin 2))))))
345        ((and cname (f2cl-lib:fstring-= c2 "UN"))
346         (cond
347           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
348            (cond
349              ((or (f2cl-lib:fstring-= c4 "QR")
350                   (f2cl-lib:fstring-= c4 "RQ")
351                   (f2cl-lib:fstring-= c4 "LQ")
352                   (f2cl-lib:fstring-= c4 "QL")
353                   (f2cl-lib:fstring-= c4 "HR")
354                   (f2cl-lib:fstring-= c4 "TR")
355                   (f2cl-lib:fstring-= c4 "BR"))
356               (setf nbmin 2))))
357           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M")
358            (cond
359              ((or (f2cl-lib:fstring-= c4 "QR")
360                   (f2cl-lib:fstring-= c4 "RQ")
361                   (f2cl-lib:fstring-= c4 "LQ")
362                   (f2cl-lib:fstring-= c4 "QL")
363                   (f2cl-lib:fstring-= c4 "HR")
364                   (f2cl-lib:fstring-= c4 "TR")
365                   (f2cl-lib:fstring-= c4 "BR"))
366               (setf nbmin 2)))))))
367      (setf ilaenv nbmin)
368      (go end_label)
369     label300
370      (setf nx 0)
371      (cond
372        ((f2cl-lib:fstring-= c2 "GE")
373         (cond
374           ((or (f2cl-lib:fstring-= c3 "QRF")
375                (f2cl-lib:fstring-= c3 "RQF")
376                (f2cl-lib:fstring-= c3 "LQF")
377                (f2cl-lib:fstring-= c3 "QLF"))
378            (cond
379              (sname
380               (setf nx 128))
381              (t
382               (setf nx 128))))
383           ((f2cl-lib:fstring-= c3 "HRD")
384            (cond
385              (sname
386               (setf nx 128))
387              (t
388               (setf nx 128))))
389           ((f2cl-lib:fstring-= c3 "BRD")
390            (cond
391              (sname
392               (setf nx 128))
393              (t
394               (setf nx 128))))))
395        ((f2cl-lib:fstring-= c2 "SY")
396         (cond
397           ((and sname (f2cl-lib:fstring-= c3 "TRD"))
398            (setf nx 32))))
399        ((and cname (f2cl-lib:fstring-= c2 "HE"))
400         (cond
401           ((f2cl-lib:fstring-= c3 "TRD")
402            (setf nx 32))))
403        ((and sname (f2cl-lib:fstring-= c2 "OR"))
404         (cond
405           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
406            (cond
407              ((or (f2cl-lib:fstring-= c4 "QR")
408                   (f2cl-lib:fstring-= c4 "RQ")
409                   (f2cl-lib:fstring-= c4 "LQ")
410                   (f2cl-lib:fstring-= c4 "QL")
411                   (f2cl-lib:fstring-= c4 "HR")
412                   (f2cl-lib:fstring-= c4 "TR")
413                   (f2cl-lib:fstring-= c4 "BR"))
414               (setf nx 128))))))
415        ((and cname (f2cl-lib:fstring-= c2 "UN"))
416         (cond
417           ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G")
418            (cond
419              ((or (f2cl-lib:fstring-= c4 "QR")
420                   (f2cl-lib:fstring-= c4 "RQ")
421                   (f2cl-lib:fstring-= c4 "LQ")
422                   (f2cl-lib:fstring-= c4 "QL")
423                   (f2cl-lib:fstring-= c4 "HR")
424                   (f2cl-lib:fstring-= c4 "TR")
425                   (f2cl-lib:fstring-= c4 "BR"))
426               (setf nx 128)))))))
427      (setf ilaenv nx)
428      (go end_label)
429     label400
430      (setf ilaenv 6)
431      (go end_label)
432     label500
433      (setf ilaenv 2)
434      (go end_label)
435     label600
436      (setf ilaenv
437              (f2cl-lib:int
438               (*
439                (f2cl-lib:freal
440                 (min (the f2cl-lib:integer4 n1) (the f2cl-lib:integer4 n2)))
441                1.6f0)))
442      (go end_label)
443     label700
444      (setf ilaenv 1)
445      (go end_label)
446     label800
447      (setf ilaenv 50)
448      (go end_label)
449     label900
450      (setf ilaenv 25)
451      (go end_label)
452     label1000
453      (setf ilaenv 0)
454      (cond
455        ((= ilaenv 1)
456         (setf ilaenv (ieeeck 0 0.0f0 1.0f0))))
457      (go end_label)
458     label1100
459      (setf ilaenv 0)
460      (cond
461        ((= ilaenv 1)
462         (setf ilaenv (ieeeck 1 0.0f0 1.0f0))))
463      (go end_label)
464     end_label
465      (return (values ilaenv nil nil nil nil nil nil nil)))))
466
467(in-package #-gcl #:cl-user #+gcl "CL-USER")
468#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
469(eval-when (:load-toplevel :compile-toplevel :execute)
470  (setf (gethash 'fortran-to-lisp::ilaenv
471                 fortran-to-lisp::*f2cl-function-info*)
472          (fortran-to-lisp::make-f2cl-finfo
473           :arg-types '((fortran-to-lisp::integer4) (simple-string)
474                        (simple-string) (fortran-to-lisp::integer4)
475                        (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
476                        (fortran-to-lisp::integer4))
477           :return-values '(nil nil nil nil nil nil nil)
478           :calls '(fortran-to-lisp::ieeeck))))
479
480