share/hompack/lisp/fodeds.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 fodeds (s y yp ypold a qr lenqr pivot pp work nfe n iflag par ipar)
  21   (declare (type (array f2cl-lib:integer4 (*)) ipar)
  22            (type (array double-float (*)) par)
  23            (type (array f2cl-lib:integer4 (*)) pivot)
  24            (type (f2cl-lib:integer4) iflag n nfe lenqr)
  25            (type (array double-float (*)) work pp qr a ypold yp y)
  26            (type (double-float) s))
  27   (f2cl-lib:with-multi-array-data
  28       ((y double-float y-%data% y-%offset%)
  29        (yp double-float yp-%data% yp-%offset%)
  30        (ypold double-float ypold-%data% ypold-%offset%)
  31        (a double-float a-%data% a-%offset%)
  32        (qr double-float qr-%data% qr-%offset%)
  33        (pp double-float pp-%data% pp-%offset%)
  34        (work double-float work-%data% work-%offset%)
  35        (pivot f2cl-lib:integer4 pivot-%data% pivot-%offset%)
  36        (par double-float par-%data% par-%offset%)
  37        (ipar f2cl-lib:integer4 ipar-%data% ipar-%offset%))
  38     (prog ((j 0) (np1 0) (temp 0.0) (ypnorm 0.0) (lambda$ 0.0))
  39       (declare (type (double-float) lambda$ ypnorm temp)
  40                (type (f2cl-lib:integer4) np1 j))
  41       (setf np1 (f2cl-lib:int-add n 1))
  42       (setf nfe (f2cl-lib:int-add nfe 1))
  43       (setf lambda$
  44               (f2cl-lib:fref y-%data%
  45                              (np1)
  46                              ((1 (f2cl-lib:int-add n 1)))
  47                              y-%offset%))
  48       (cond
  49         ((= iflag (f2cl-lib:int-sub 2))
  50          (rhojs a lambda$ y qr lenqr pivot pp par ipar))
  51         (t
  52          (f y pp)
  53          (cond
  54            ((= iflag 0)
  55             (daxpy n -1.0 a 1 pp 1)
  56             (fjacs y qr lenqr pivot)
  57             (dscal lenqr (- lambda$) qr 1)
  58             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  59                           ((> j n) nil)
  60               (tagbody
  61                 (setf (f2cl-lib:fref qr-%data%
  62                                      ((f2cl-lib:fref pivot
  63                                                      (j)
  64                                                      ((1
  65                                                        (f2cl-lib:int-add n
  66                                                                          2)))))
  67                                      ((1 lenqr))
  68                                      qr-%offset%)
  69                         (+
  70                          (f2cl-lib:fref qr-%data%
  71                                         ((f2cl-lib:fref pivot
  72                                                         (j)
  73                                                         ((1
  74                                                           (f2cl-lib:int-add n
  75                                                                             2)))))
  76                                         ((1 lenqr))
  77                                         qr-%offset%)
  78                          1.0f0))
  79                label120)))
  80            (t
  81             (dscal n -1.0 pp 1)
  82             (daxpy n 1.0 y 1 pp 1)
  83             (daxpy n -1.0 a 1 pp 1)
  84             (fjacs y qr lenqr pivot)
  85             (dscal lenqr lambda$ qr 1)
  86             (setf temp (- 1.0f0 lambda$))
  87             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  88                           ((> j n) nil)
  89               (tagbody
  90                 (setf (f2cl-lib:fref qr-%data%
  91                                      ((f2cl-lib:fref pivot
  92                                                      (j)
  93                                                      ((1
  94                                                        (f2cl-lib:int-add n
  95                                                                          2)))))
  96                                      ((1 lenqr))
  97                                      qr-%offset%)
  98                         (+
  99                          (f2cl-lib:fref qr-%data%
 100                                         ((f2cl-lib:fref pivot
 101                                                         (j)
 102                                                         ((1
 103                                                           (f2cl-lib:int-add n
 104                                                                             2)))))
 105                                         ((1 lenqr))
 106                                         qr-%offset%)
 107                          temp))
 108                label170))))))
 109       (dcopy np1 ypold 1 yp 1)
 110       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 111           (pcgds n qr lenqr pivot pp yp work iflag)
 112         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6))
 113         (setf iflag var-7))
 114       (if (> iflag 0) (go end_label))
 115       (setf ypnorm (dnrm2 np1 yp 1))
 116       (dscal np1 (/ 1.0f0 ypnorm) yp 1)
 117       (if (< (ddot np1 yp 1 ypold 1) 0.0f0) (dscal np1 -1.0 yp 1))
 118       (dcopy np1 yp 1 ypold 1)
 119       (go end_label)
 120      end_label
 121       (return
 122        (values nil
 123                nil
 124                nil
 125                nil
 126                nil
 127                nil
 128                nil
 129                nil
 130                nil
 131                nil
 132                nfe
 133                nil
 134                iflag
 135                nil
 136                nil)))))
 137
 138 (in-package #:cl-user)
 139 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 140 (eval-when (:load-toplevel :compile-toplevel :execute)
 141   (setf (gethash 'fortran-to-lisp::fodeds
 142                  fortran-to-lisp::*f2cl-function-info*)
 143           (fortran-to-lisp::make-f2cl-finfo
 144            :arg-types '((double-float) (array double-float (*))
 145                         (array double-float (*)) (array double-float (*))
 146                         (array double-float (*)) (array double-float (*))
 147                         (fortran-to-lisp::integer4)
 148                         (array fortran-to-lisp::integer4 (*))
 149                         (array double-float (*)) (array double-float (*))
 150                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 151                         (fortran-to-lisp::integer4) (array double-float (*))
 152                         (array fortran-to-lisp::integer4 (*)))
 153            :return-values '(nil nil nil nil nil nil nil nil nil nil
 154                             fortran-to-lisp::nfe nil fortran-to-lisp::iflag nil
 155                             nil)
 156            :calls '(fortran-to-lisp::fjacs fortran-to-lisp::f
 157                     fortran-to-lisp::rhojs fortran-to-lisp::ddot
 158                     fortran-to-lisp::dnrm2 fortran-to-lisp::dcopy
 159                     fortran-to-lisp::dscal fortran-to-lisp::daxpy
 160                     fortran-to-lisp::pcgds))))
 161