share/odepack/src/dheqr.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-2013-11 (20E 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 single-float))
  16
  17 (in-package "ODEPACK")
  18
  19
  20 (defun dheqr (a lda n q info ijob)
  21   (declare (type (f2cl-lib:integer4) ijob info n lda)
  22            (type (array double-float (*)) q a))
  23   (f2cl-lib:with-multi-array-data
  24       ((a double-float a-%data% a-%offset%)
  25        (q double-float q-%data% q-%offset%))
  26     (prog ((c 0.0d0) (s 0.0d0) (t$ 0.0d0) (t1 0.0d0) (t2 0.0d0) (i 0) (iq 0)
  27            (j 0) (k 0) (km1 0) (kp1 0) (nm1 0))
  28       (declare (type (f2cl-lib:integer4) nm1 kp1 km1 k j iq i)
  29                (type (double-float) t2 t1 t$ s c))
  30       (if (> ijob 1) (go label70))
  31       (setf info 0)
  32       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  33                     ((> k n) nil)
  34         (tagbody
  35           (setf km1 (f2cl-lib:int-sub k 1))
  36           (setf kp1 (f2cl-lib:int-add k 1))
  37           (if (< km1 1) (go label20))
  38           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  39                         ((> j km1) nil)
  40             (tagbody
  41               (setf i
  42                       (f2cl-lib:int-add
  43                        (f2cl-lib:int-mul 2 (f2cl-lib:int-sub j 1))
  44                        1))
  45               (setf t1
  46                       (f2cl-lib:fref a-%data%
  47                                      (j k)
  48                                      ((1 lda) (1 *))
  49                                      a-%offset%))
  50               (setf t2
  51                       (f2cl-lib:fref a-%data%
  52                                      ((f2cl-lib:int-add j 1) k)
  53                                      ((1 lda) (1 *))
  54                                      a-%offset%))
  55               (setf c (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%))
  56               (setf s
  57                       (f2cl-lib:fref q-%data%
  58                                      ((f2cl-lib:int-add i 1))
  59                                      ((1 *))
  60                                      q-%offset%))
  61               (setf (f2cl-lib:fref a-%data% (j k) ((1 lda) (1 *)) a-%offset%)
  62                       (- (* c t1) (* s t2)))
  63               (setf (f2cl-lib:fref a-%data%
  64                                    ((f2cl-lib:int-add j 1) k)
  65                                    ((1 lda) (1 *))
  66                                    a-%offset%)
  67                       (+ (* s t1) (* c t2)))
  68              label10))
  69          label20
  70           (setf iq (f2cl-lib:int-add (f2cl-lib:int-mul 2 km1) 1))
  71           (setf t1 (f2cl-lib:fref a-%data% (k k) ((1 lda) (1 *)) a-%offset%))
  72           (setf t2 (f2cl-lib:fref a-%data% (kp1 k) ((1 lda) (1 *)) a-%offset%))
  73           (if (/= t2 0.0d0) (go label30))
  74           (setf c 1.0d0)
  75           (setf s 0.0d0)
  76           (go label50)
  77          label30
  78           (if (< (abs t2) (abs t1)) (go label40))
  79           (setf t$ (/ t1 t2))
  80           (setf s (/ -1.0d0 (f2cl-lib:fsqrt (+ 1.0d0 (* t$ t$)))))
  81           (setf c (* (- s) t$))
  82           (go label50)
  83          label40
  84           (setf t$ (/ t2 t1))
  85           (setf c (/ 1.0d0 (f2cl-lib:fsqrt (+ 1.0d0 (* t$ t$)))))
  86           (setf s (* (- c) t$))
  87          label50
  88           (setf (f2cl-lib:fref q-%data% (iq) ((1 *)) q-%offset%) c)
  89           (setf (f2cl-lib:fref q-%data%
  90                                ((f2cl-lib:int-add iq 1))
  91                                ((1 *))
  92                                q-%offset%)
  93                   s)
  94           (setf (f2cl-lib:fref a-%data% (k k) ((1 lda) (1 *)) a-%offset%)
  95                   (- (* c t1) (* s t2)))
  96           (if
  97            (= (f2cl-lib:fref a-%data% (k k) ((1 lda) (1 *)) a-%offset%) 0.0d0)
  98            (setf info k))
  99          label60))
 100       (go end_label)
 101      label70
 102       (setf nm1 (f2cl-lib:int-sub n 1))
 103       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 104                     ((> k nm1) nil)
 105         (tagbody
 106           (setf i
 107                   (f2cl-lib:int-add (f2cl-lib:int-mul 2 (f2cl-lib:int-sub k 1))
 108                                     1))
 109           (setf t1 (f2cl-lib:fref a-%data% (k n) ((1 lda) (1 *)) a-%offset%))
 110           (setf t2
 111                   (f2cl-lib:fref a-%data%
 112                                  ((f2cl-lib:int-add k 1) n)
 113                                  ((1 lda) (1 *))
 114                                  a-%offset%))
 115           (setf c (f2cl-lib:fref q-%data% (i) ((1 *)) q-%offset%))
 116           (setf s
 117                   (f2cl-lib:fref q-%data%
 118                                  ((f2cl-lib:int-add i 1))
 119                                  ((1 *))
 120                                  q-%offset%))
 121           (setf (f2cl-lib:fref a-%data% (k n) ((1 lda) (1 *)) a-%offset%)
 122                   (- (* c t1) (* s t2)))
 123           (setf (f2cl-lib:fref a-%data%
 124                                ((f2cl-lib:int-add k 1) n)
 125                                ((1 lda) (1 *))
 126                                a-%offset%)
 127                   (+ (* s t1) (* c t2)))
 128          label100))
 129       (setf info 0)
 130       (setf t1 (f2cl-lib:fref a-%data% (n n) ((1 lda) (1 *)) a-%offset%))
 131       (setf t2
 132               (f2cl-lib:fref a-%data%
 133                              ((f2cl-lib:int-add n 1) n)
 134                              ((1 lda) (1 *))
 135                              a-%offset%))
 136       (if (/= t2 0.0d0) (go label110))
 137       (setf c 1.0d0)
 138       (setf s 0.0d0)
 139       (go label130)
 140      label110
 141       (if (< (abs t2) (abs t1)) (go label120))
 142       (setf t$ (/ t1 t2))
 143       (setf s (/ -1.0d0 (f2cl-lib:fsqrt (+ 1.0d0 (* t$ t$)))))
 144       (setf c (* (- s) t$))
 145       (go label130)
 146      label120
 147       (setf t$ (/ t2 t1))
 148       (setf c (/ 1.0d0 (f2cl-lib:fsqrt (+ 1.0d0 (* t$ t$)))))
 149       (setf s (* (- c) t$))
 150      label130
 151       (setf iq (f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1))
 152       (setf (f2cl-lib:fref q-%data% (iq) ((1 *)) q-%offset%) c)
 153       (setf (f2cl-lib:fref q-%data%
 154                            ((f2cl-lib:int-add iq 1))
 155                            ((1 *))
 156                            q-%offset%)
 157               s)
 158       (setf (f2cl-lib:fref a-%data% (n n) ((1 lda) (1 *)) a-%offset%)
 159               (- (* c t1) (* s t2)))
 160       (if (= (f2cl-lib:fref a-%data% (n n) ((1 lda) (1 *)) a-%offset%) 0.0d0)
 161           (setf info n))
 162       (go end_label)
 163      end_label
 164       (return (values nil nil nil nil info nil)))))
 165
 166 (in-package #:cl-user)
 167 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 168 (eval-when (:load-toplevel :compile-toplevel :execute)
 169   (setf (gethash 'fortran-to-lisp::dheqr fortran-to-lisp::*f2cl-function-info*)
 170           (fortran-to-lisp::make-f2cl-finfo
 171            :arg-types '((array double-float (*)) (fortran-to-lisp::integer4)
 172                         (fortran-to-lisp::integer4) (array double-float (*))
 173                         (fortran-to-lisp::integer4)
 174                         (fortran-to-lisp::integer4))
 175            :return-values '(nil nil nil nil fortran-to-lisp::info nil)
 176            :calls 'nil)))
 177