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 :blas)
18
19
20(let* ((zero (f2cl-lib:cmplx 0.0 0.0)))
21  (declare (type (f2cl-lib:complex16) zero) (ignorable zero))
22  (defun ztpmv (uplo trans diag n ap x incx)
23    (declare (type (array f2cl-lib:complex16 (*)) x ap)
24             (type (f2cl-lib:integer4) incx n)
25             (type (simple-string *) diag trans uplo))
26    (f2cl-lib:with-multi-array-data
27        ((uplo character uplo-%data% uplo-%offset%)
28         (trans character trans-%data% trans-%offset%)
29         (diag character diag-%data% diag-%offset%)
30         (ap f2cl-lib:complex16 ap-%data% ap-%offset%)
31         (x f2cl-lib:complex16 x-%data% x-%offset%))
32      (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0)
33             (kk 0) (kx 0) (temp #C(0.0 0.0)))
34        (declare (type f2cl-lib:logical noconj nounit)
35                 (type (f2cl-lib:integer4) i info ix j jx k kk kx)
36                 (type (f2cl-lib:complex16) temp))
37        (setf info 0)
38        (cond
39          ((and (not (lsame uplo "U")) (not (lsame uplo "L")))
40           (setf info 1))
41          ((and (not (lsame trans "N"))
42                (not (lsame trans "T"))
43                (not (lsame trans "C")))
44           (setf info 2))
45          ((and (not (lsame diag "U")) (not (lsame diag "N")))
46           (setf info 3))
47          ((< n 0)
48           (setf info 4))
49          ((= incx 0)
50           (setf info 7)))
51        (cond
52          ((/= info 0)
53           (xerbla "ZTPMV " info)
54           (go end_label)))
55        (if (= n 0) (go end_label))
56        (setf noconj (lsame trans "T"))
57        (setf nounit (lsame diag "N"))
58        (cond
59          ((<= incx 0)
60           (setf kx
61                   (f2cl-lib:int-sub 1
62                                     (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
63                                                       incx))))
64          ((/= incx 1)
65           (setf kx 1)))
66        (cond
67          ((lsame trans "N")
68           (cond
69             ((lsame uplo "U")
70              (setf kk 1)
71              (cond
72                ((= incx 1)
73                 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
74                               ((> j n) nil)
75                   (tagbody
76                     (cond
77                       ((/= (f2cl-lib:fref x (j) ((1 *))) zero)
78                        (setf temp
79                                (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
80                        (setf k kk)
81                        (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
82                                      ((> i
83                                          (f2cl-lib:int-add j
84                                                            (f2cl-lib:int-sub
85                                                             1)))
86                                       nil)
87                          (tagbody
88                            (setf (f2cl-lib:fref x-%data%
89                                                 (i)
90                                                 ((1 *))
91                                                 x-%offset%)
92                                    (+
93                                     (f2cl-lib:fref x-%data%
94                                                    (i)
95                                                    ((1 *))
96                                                    x-%offset%)
97                                     (* temp
98                                        (f2cl-lib:fref ap-%data%
99                                                       (k)
100                                                       ((1 *))
101                                                       ap-%offset%))))
102                            (setf k (f2cl-lib:int-add k 1))
103                           label10))
104                        (if nounit
105                            (setf (f2cl-lib:fref x-%data%
106                                                 (j)
107                                                 ((1 *))
108                                                 x-%offset%)
109                                    (*
110                                     (f2cl-lib:fref x-%data%
111                                                    (j)
112                                                    ((1 *))
113                                                    x-%offset%)
114                                     (f2cl-lib:fref ap-%data%
115                                                    ((f2cl-lib:int-sub
116                                                      (f2cl-lib:int-add kk j)
117                                                      1))
118                                                    ((1 *))
119                                                    ap-%offset%))))))
120                     (setf kk (f2cl-lib:int-add kk j))
121                    label20)))
122                (t
123                 (setf jx kx)
124                 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
125                               ((> j n) nil)
126                   (tagbody
127                     (cond
128                       ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
129                        (setf temp
130                                (f2cl-lib:fref x-%data%
131                                               (jx)
132                                               ((1 *))
133                                               x-%offset%))
134                        (setf ix kx)
135                        (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1))
136                                      ((> k
137                                          (f2cl-lib:int-add kk
138                                                            j
139                                                            (f2cl-lib:int-sub
140                                                             2)))
141                                       nil)
142                          (tagbody
143                            (setf (f2cl-lib:fref x-%data%
144                                                 (ix)
145                                                 ((1 *))
146                                                 x-%offset%)
147                                    (+
148                                     (f2cl-lib:fref x-%data%
149                                                    (ix)
150                                                    ((1 *))
151                                                    x-%offset%)
152                                     (* temp
153                                        (f2cl-lib:fref ap-%data%
154                                                       (k)
155                                                       ((1 *))
156                                                       ap-%offset%))))
157                            (setf ix (f2cl-lib:int-add ix incx))
158                           label30))
159                        (if nounit
160                            (setf (f2cl-lib:fref x-%data%
161                                                 (jx)
162                                                 ((1 *))
163                                                 x-%offset%)
164                                    (*
165                                     (f2cl-lib:fref x-%data%
166                                                    (jx)
167                                                    ((1 *))
168                                                    x-%offset%)
169                                     (f2cl-lib:fref ap-%data%
170                                                    ((f2cl-lib:int-sub
171                                                      (f2cl-lib:int-add kk j)
172                                                      1))
173                                                    ((1 *))
174                                                    ap-%offset%))))))
175                     (setf jx (f2cl-lib:int-add jx incx))
176                     (setf kk (f2cl-lib:int-add kk j))
177                    label40)))))
178             (t
179              (setf kk (the f2cl-lib:integer4 (truncate (* n (+ n 1)) 2)))
180              (cond
181                ((= incx 1)
182                 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
183                               ((> j 1) nil)
184                   (tagbody
185                     (cond
186                       ((/= (f2cl-lib:fref x (j) ((1 *))) zero)
187                        (setf temp
188                                (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
189                        (setf k kk)
190                        (f2cl-lib:fdo (i n
191                                       (f2cl-lib:int-add i
192                                                         (f2cl-lib:int-sub 1)))
193                                      ((> i (f2cl-lib:int-add j 1)) nil)
194                          (tagbody
195                            (setf (f2cl-lib:fref x-%data%
196                                                 (i)
197                                                 ((1 *))
198                                                 x-%offset%)
199                                    (+
200                                     (f2cl-lib:fref x-%data%
201                                                    (i)
202                                                    ((1 *))
203                                                    x-%offset%)
204                                     (* temp
205                                        (f2cl-lib:fref ap-%data%
206                                                       (k)
207                                                       ((1 *))
208                                                       ap-%offset%))))
209                            (setf k (f2cl-lib:int-sub k 1))
210                           label50))
211                        (if nounit
212                            (setf (f2cl-lib:fref x-%data%
213                                                 (j)
214                                                 ((1 *))
215                                                 x-%offset%)
216                                    (*
217                                     (f2cl-lib:fref x-%data%
218                                                    (j)
219                                                    ((1 *))
220                                                    x-%offset%)
221                                     (f2cl-lib:fref ap-%data%
222                                                    ((f2cl-lib:int-add
223                                                      (f2cl-lib:int-sub kk n)
224                                                      j))
225                                                    ((1 *))
226                                                    ap-%offset%))))))
227                     (setf kk
228                             (f2cl-lib:int-sub kk
229                                               (f2cl-lib:int-add
230                                                (f2cl-lib:int-sub n j)
231                                                1)))
232                    label60)))
233                (t
234                 (setf kx
235                         (f2cl-lib:int-add kx
236                                           (f2cl-lib:int-mul
237                                            (f2cl-lib:int-sub n 1)
238                                            incx)))
239                 (setf jx kx)
240                 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
241                               ((> j 1) nil)
242                   (tagbody
243                     (cond
244                       ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
245                        (setf temp
246                                (f2cl-lib:fref x-%data%
247                                               (jx)
248                                               ((1 *))
249                                               x-%offset%))
250                        (setf ix kx)
251                        (f2cl-lib:fdo (k kk
252                                       (f2cl-lib:int-add k
253                                                         (f2cl-lib:int-sub 1)))
254                                      ((> k
255                                          (f2cl-lib:int-add kk
256                                                            (f2cl-lib:int-sub
257                                                             (f2cl-lib:int-add
258                                                              n
259                                                              (f2cl-lib:int-sub
260                                                               (f2cl-lib:int-add
261                                                                j
262                                                                1))))))
263                                       nil)
264                          (tagbody
265                            (setf (f2cl-lib:fref x-%data%
266                                                 (ix)
267                                                 ((1 *))
268                                                 x-%offset%)
269                                    (+
270                                     (f2cl-lib:fref x-%data%
271                                                    (ix)
272                                                    ((1 *))
273                                                    x-%offset%)
274                                     (* temp
275                                        (f2cl-lib:fref ap-%data%
276                                                       (k)
277                                                       ((1 *))
278                                                       ap-%offset%))))
279                            (setf ix (f2cl-lib:int-sub ix incx))
280                           label70))
281                        (if nounit
282                            (setf (f2cl-lib:fref x-%data%
283                                                 (jx)
284                                                 ((1 *))
285                                                 x-%offset%)
286                                    (*
287                                     (f2cl-lib:fref x-%data%
288                                                    (jx)
289                                                    ((1 *))
290                                                    x-%offset%)
291                                     (f2cl-lib:fref ap-%data%
292                                                    ((f2cl-lib:int-add
293                                                      (f2cl-lib:int-sub kk n)
294                                                      j))
295                                                    ((1 *))
296                                                    ap-%offset%))))))
297                     (setf jx (f2cl-lib:int-sub jx incx))
298                     (setf kk
299                             (f2cl-lib:int-sub kk
300                                               (f2cl-lib:int-add
301                                                (f2cl-lib:int-sub n j)
302                                                1)))
303                    label80)))))))
304          (t
305           (cond
306             ((lsame uplo "U")
307              (setf kk (the f2cl-lib:integer4 (truncate (* n (+ n 1)) 2)))
308              (cond
309                ((= incx 1)
310                 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
311                               ((> j 1) nil)
312                   (tagbody
313                     (setf temp
314                             (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
315                     (setf k (f2cl-lib:int-sub kk 1))
316                     (cond
317                       (noconj
318                        (if nounit
319                            (setf temp
320                                    (* temp
321                                       (f2cl-lib:fref ap-%data%
322                                                      (kk)
323                                                      ((1 *))
324                                                      ap-%offset%))))
325                        (f2cl-lib:fdo (i
326                                       (f2cl-lib:int-add j
327                                                         (f2cl-lib:int-sub 1))
328                                       (f2cl-lib:int-add i
329                                                         (f2cl-lib:int-sub 1)))
330                                      ((> i 1) nil)
331                          (tagbody
332                            (setf temp
333                                    (+ temp
334                                       (*
335                                        (f2cl-lib:fref ap-%data%
336                                                       (k)
337                                                       ((1 *))
338                                                       ap-%offset%)
339                                        (f2cl-lib:fref x-%data%
340                                                       (i)
341                                                       ((1 *))
342                                                       x-%offset%))))
343                            (setf k (f2cl-lib:int-sub k 1))
344                           label90)))
345                       (t
346                        (if nounit
347                            (setf temp
348                                    (* temp
349                                       (f2cl-lib:dconjg
350                                        (f2cl-lib:fref ap-%data%
351                                                       (kk)
352                                                       ((1 *))
353                                                       ap-%offset%)))))
354                        (f2cl-lib:fdo (i
355                                       (f2cl-lib:int-add j
356                                                         (f2cl-lib:int-sub 1))
357                                       (f2cl-lib:int-add i
358                                                         (f2cl-lib:int-sub 1)))
359                                      ((> i 1) nil)
360                          (tagbody
361                            (setf temp
362                                    (+ temp
363                                       (*
364                                        (f2cl-lib:dconjg
365                                         (f2cl-lib:fref ap-%data%
366                                                        (k)
367                                                        ((1 *))
368                                                        ap-%offset%))
369                                        (f2cl-lib:fref x-%data%
370                                                       (i)
371                                                       ((1 *))
372                                                       x-%offset%))))
373                            (setf k (f2cl-lib:int-sub k 1))
374                           label100))))
375                     (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)
376                             temp)
377                     (setf kk (f2cl-lib:int-sub kk j))
378                    label110)))
379                (t
380                 (setf jx
381                         (f2cl-lib:int-add kx
382                                           (f2cl-lib:int-mul
383                                            (f2cl-lib:int-sub n 1)
384                                            incx)))
385                 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
386                               ((> j 1) nil)
387                   (tagbody
388                     (setf temp
389                             (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))
390                     (setf ix jx)
391                     (cond
392                       (noconj
393                        (if nounit
394                            (setf temp
395                                    (* temp
396                                       (f2cl-lib:fref ap-%data%
397                                                      (kk)
398                                                      ((1 *))
399                                                      ap-%offset%))))
400                        (f2cl-lib:fdo (k
401                                       (f2cl-lib:int-add kk
402                                                         (f2cl-lib:int-sub 1))
403                                       (f2cl-lib:int-add k
404                                                         (f2cl-lib:int-sub 1)))
405                                      ((> k
406                                          (f2cl-lib:int-add kk
407                                                            (f2cl-lib:int-sub
408                                                             j)
409                                                            1))
410                                       nil)
411                          (tagbody
412                            (setf ix (f2cl-lib:int-sub ix incx))
413                            (setf temp
414                                    (+ temp
415                                       (*
416                                        (f2cl-lib:fref ap-%data%
417                                                       (k)
418                                                       ((1 *))
419                                                       ap-%offset%)
420                                        (f2cl-lib:fref x-%data%
421                                                       (ix)
422                                                       ((1 *))
423                                                       x-%offset%))))
424                           label120)))
425                       (t
426                        (if nounit
427                            (setf temp
428                                    (* temp
429                                       (f2cl-lib:dconjg
430                                        (f2cl-lib:fref ap-%data%
431                                                       (kk)
432                                                       ((1 *))
433                                                       ap-%offset%)))))
434                        (f2cl-lib:fdo (k
435                                       (f2cl-lib:int-add kk
436                                                         (f2cl-lib:int-sub 1))
437                                       (f2cl-lib:int-add k
438                                                         (f2cl-lib:int-sub 1)))
439                                      ((> k
440                                          (f2cl-lib:int-add kk
441                                                            (f2cl-lib:int-sub
442                                                             j)
443                                                            1))
444                                       nil)
445                          (tagbody
446                            (setf ix (f2cl-lib:int-sub ix incx))
447                            (setf temp
448                                    (+ temp
449                                       (*
450                                        (f2cl-lib:dconjg
451                                         (f2cl-lib:fref ap-%data%
452                                                        (k)
453                                                        ((1 *))
454                                                        ap-%offset%))
455                                        (f2cl-lib:fref x-%data%
456                                                       (ix)
457                                                       ((1 *))
458                                                       x-%offset%))))
459                           label130))))
460                     (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)
461                             temp)
462                     (setf jx (f2cl-lib:int-sub jx incx))
463                     (setf kk (f2cl-lib:int-sub kk j))
464                    label140)))))
465             (t
466              (setf kk 1)
467              (cond
468                ((= incx 1)
469                 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
470                               ((> j n) nil)
471                   (tagbody
472                     (setf temp
473                             (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
474                     (setf k (f2cl-lib:int-add kk 1))
475                     (cond
476                       (noconj
477                        (if nounit
478                            (setf temp
479                                    (* temp
480                                       (f2cl-lib:fref ap-%data%
481                                                      (kk)
482                                                      ((1 *))
483                                                      ap-%offset%))))
484                        (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
485                                       (f2cl-lib:int-add i 1))
486                                      ((> i n) nil)
487                          (tagbody
488                            (setf temp
489                                    (+ temp
490                                       (*
491                                        (f2cl-lib:fref ap-%data%
492                                                       (k)
493                                                       ((1 *))
494                                                       ap-%offset%)
495                                        (f2cl-lib:fref x-%data%
496                                                       (i)
497                                                       ((1 *))
498                                                       x-%offset%))))
499                            (setf k (f2cl-lib:int-add k 1))
500                           label150)))
501                       (t
502                        (if nounit
503                            (setf temp
504                                    (* temp
505                                       (f2cl-lib:dconjg
506                                        (f2cl-lib:fref ap-%data%
507                                                       (kk)
508                                                       ((1 *))
509                                                       ap-%offset%)))))
510                        (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
511                                       (f2cl-lib:int-add i 1))
512                                      ((> i n) nil)
513                          (tagbody
514                            (setf temp
515                                    (+ temp
516                                       (*
517                                        (f2cl-lib:dconjg
518                                         (f2cl-lib:fref ap-%data%
519                                                        (k)
520                                                        ((1 *))
521                                                        ap-%offset%))
522                                        (f2cl-lib:fref x-%data%
523                                                       (i)
524                                                       ((1 *))
525                                                       x-%offset%))))
526                            (setf k (f2cl-lib:int-add k 1))
527                           label160))))
528                     (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)
529                             temp)
530                     (setf kk
531                             (f2cl-lib:int-add kk
532                                               (f2cl-lib:int-add
533                                                (f2cl-lib:int-sub n j)
534                                                1)))
535                    label170)))
536                (t
537                 (setf jx kx)
538                 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
539                               ((> j n) nil)
540                   (tagbody
541                     (setf temp
542                             (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))
543                     (setf ix jx)
544                     (cond
545                       (noconj
546                        (if nounit
547                            (setf temp
548                                    (* temp
549                                       (f2cl-lib:fref ap-%data%
550                                                      (kk)
551                                                      ((1 *))
552                                                      ap-%offset%))))
553                        (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1)
554                                       (f2cl-lib:int-add k 1))
555                                      ((> k
556                                          (f2cl-lib:int-add kk
557                                                            n
558                                                            (f2cl-lib:int-sub
559                                                             j)))
560                                       nil)
561                          (tagbody
562                            (setf ix (f2cl-lib:int-add ix incx))
563                            (setf temp
564                                    (+ temp
565                                       (*
566                                        (f2cl-lib:fref ap-%data%
567                                                       (k)
568                                                       ((1 *))
569                                                       ap-%offset%)
570                                        (f2cl-lib:fref x-%data%
571                                                       (ix)
572                                                       ((1 *))
573                                                       x-%offset%))))
574                           label180)))
575                       (t
576                        (if nounit
577                            (setf temp
578                                    (* temp
579                                       (f2cl-lib:dconjg
580                                        (f2cl-lib:fref ap-%data%
581                                                       (kk)
582                                                       ((1 *))
583                                                       ap-%offset%)))))
584                        (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1)
585                                       (f2cl-lib:int-add k 1))
586                                      ((> k
587                                          (f2cl-lib:int-add kk
588                                                            n
589                                                            (f2cl-lib:int-sub
590                                                             j)))
591                                       nil)
592                          (tagbody
593                            (setf ix (f2cl-lib:int-add ix incx))
594                            (setf temp
595                                    (+ temp
596                                       (*
597                                        (f2cl-lib:dconjg
598                                         (f2cl-lib:fref ap-%data%
599                                                        (k)
600                                                        ((1 *))
601                                                        ap-%offset%))
602                                        (f2cl-lib:fref x-%data%
603                                                       (ix)
604                                                       ((1 *))
605                                                       x-%offset%))))
606                           label190))))
607                     (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)
608                             temp)
609                     (setf jx (f2cl-lib:int-add jx incx))
610                     (setf kk
611                             (f2cl-lib:int-add kk
612                                               (f2cl-lib:int-add
613                                                (f2cl-lib:int-sub n j)
614                                                1)))
615                    label200))))))))
616        (go end_label)
617       end_label
618        (return (values nil nil nil nil nil nil nil))))))
619
620(in-package #-gcl #:cl-user #+gcl "CL-USER")
621#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
622(eval-when (:load-toplevel :compile-toplevel :execute)
623  (setf (gethash 'fortran-to-lisp::ztpmv fortran-to-lisp::*f2cl-function-info*)
624          (fortran-to-lisp::make-f2cl-finfo
625           :arg-types '((simple-string) (simple-string) (simple-string)
626                        (fortran-to-lisp::integer4)
627                        (array fortran-to-lisp::complex16 (*))
628                        (array fortran-to-lisp::complex16 (*))
629                        (fortran-to-lisp::integer4))
630           :return-values '(nil nil nil nil nil nil nil)
631           :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))
632
633