share/hompack/lisp/upqrqf.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   3 ;;;  "f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   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 95098eb54f13 2013/04/01 00:45:16 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v 1409c1352feb 2013/03/24 20:44:50 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2020-04 (21D 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 "HOMPACK")
  18
  19
  20 (defun upqrqf (n eta s f0 f1 qt r w t$)
  21   (declare (type (array double-float (*)) t$ w r qt f1 f0 s)
  22            (type (double-float) eta)
  23            (type (f2cl-lib:integer4) n))
  24   (f2cl-lib:with-multi-array-data
  25       ((s double-float s-%data% s-%offset%)
  26        (f0 double-float f0-%data% f0-%offset%)
  27        (f1 double-float f1-%data% f1-%offset%)
  28        (qt double-float qt-%data% qt-%offset%)
  29        (r double-float r-%data% r-%offset%)
  30        (w double-float w-%data% w-%offset%)
  31        (t$ double-float t$-%data% t$-%offset%))
  32     (prog ((tt (make-array 2 :element-type 'double-float)) (skipup nil) (i 0)
  33            (indexr 0) (indxr2 0) (j 0) (k 0) (c 0.0) (den 0.0) (one 0.0)
  34            (ss 0.0) (ww 0.0) (yy 0.0) (dnrm2 0.0))
  35       (declare (type (double-float) dnrm2 yy ww ss one den c)
  36                (type (f2cl-lib:integer4) k j indxr2 indexr i)
  37                (type f2cl-lib:logical skipup)
  38                (type (array double-float (2)) tt))
  39       (setf one (coerce 1.0f0 'double-float))
  40       (setf skipup f2cl-lib:%true%)
  41       (setf indexr 1)
  42       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  43                     ((> i n) nil)
  44         (tagbody
  45           (setf (f2cl-lib:fref t$-%data% (i) ((1 n)) t$-%offset%)
  46                   (ddot (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)
  47                    (f2cl-lib:array-slice r-%data%
  48                                          double-float
  49                                          (indexr)
  50                                          ((1
  51                                            (f2cl-lib:f2cl/
  52                                             (f2cl-lib:int-mul n
  53                                                               (f2cl-lib:int-add
  54                                                                n
  55                                                                1))
  56                                             2)))
  57                                          r-%offset%)
  58                    1
  59                    (f2cl-lib:array-slice s-%data%
  60                                          double-float
  61                                          (i)
  62                                          ((1 n))
  63                                          s-%offset%)
  64                    1))
  65           (setf indexr
  66                   (f2cl-lib:int-add
  67                    (f2cl-lib:int-sub (f2cl-lib:int-add indexr n) i)
  68                    1))
  69          label10))
  70       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  71                     ((> i n) nil)
  72         (tagbody
  73           (setf (f2cl-lib:fref w-%data% (i) ((1 n)) w-%offset%)
  74                   (- (f2cl-lib:fref f1-%data% (i) ((1 n)) f1-%offset%)
  75                      (f2cl-lib:fref f0-%data% (i) ((1 n)) f0-%offset%)
  76                      (ddot n
  77                       (f2cl-lib:array-slice qt-%data%
  78                                             double-float
  79                                             (1 i)
  80                                             ((1 n) (1 n))
  81                                             qt-%offset%)
  82                       1 t$ 1)))
  83           (cond
  84             ((> (abs (f2cl-lib:fref w (i) ((1 n))))
  85                 (* eta
  86                    (+ (abs (f2cl-lib:fref f1 (i) ((1 n))))
  87                       (abs (f2cl-lib:fref f0 (i) ((1 n)))))))
  88              (setf skipup f2cl-lib:%false%))
  89             (t
  90              (setf (f2cl-lib:fref w-%data% (i) ((1 n)) w-%offset%)
  91                      (coerce 0.0f0 'double-float))))
  92          label20))
  93       (if skipup (go end_label))
  94       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  95                     ((> i n) nil)
  96         (tagbody
  97           (setf (f2cl-lib:fref t$-%data% (i) ((1 n)) t$-%offset%)
  98                   (ddot n
  99                    (f2cl-lib:array-slice qt-%data%
 100                                          double-float
 101                                          (i 1)
 102                                          ((1 n) (1 n))
 103                                          qt-%offset%)
 104                    n w 1))
 105          label30))
 106       (setf den (/ 1.0f0 (ddot n s 1 s 1)))
 107       (dscal n den s 1)
 108       (r1upqf n s t$ qt r w)
 109       (go end_label)
 110      end_label
 111       (return (values nil nil nil nil nil nil nil nil nil)))))
 112
 113 (in-package #:cl-user)
 114 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 115 (eval-when (:load-toplevel :compile-toplevel :execute)
 116   (setf (gethash 'fortran-to-lisp::upqrqf
 117                  fortran-to-lisp::*f2cl-function-info*)
 118           (fortran-to-lisp::make-f2cl-finfo
 119            :arg-types '((fortran-to-lisp::integer4) (double-float)
 120                         (array double-float (*)) (array double-float (*))
 121                         (array double-float (*)) (array double-float (*))
 122                         (array double-float (*)) (array double-float (*))
 123                         (array double-float (*)))
 124            :return-values '(nil nil nil nil nil nil nil nil nil)
 125            :calls '(fortran-to-lisp::dscal fortran-to-lisp::ddot
 126                     fortran-to-lisp::r1upqf))))
 127