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