share/odepack/src/dgbfa.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 dgbfa (abd lda n ml mu ipvt info)
  21   (declare (type (array f2cl-lib:integer4 (*)) ipvt)
  22            (type (f2cl-lib:integer4) info mu ml n lda)
  23            (type (array double-float (*)) abd))
  24   (f2cl-lib:with-multi-array-data
  25       ((abd double-float abd-%data% abd-%offset%)
  26        (ipvt f2cl-lib:integer4 ipvt-%data% ipvt-%offset%))
  27     (prog ((i 0) (i0 0) (j 0) (ju 0) (jz 0) (j0 0) (j1 0) (k 0) (kp1 0) (l 0)
  28            (lm 0) (m 0) (mm 0) (nm1 0) (t$ 0.0))
  29       (declare (type (double-float) t$)
  30                (type (f2cl-lib:integer4) nm1 mm m lm l kp1 k j1 j0 jz ju j i0
  31                                          i))
  32       (setf m (f2cl-lib:int-add ml mu 1))
  33       (setf info 0)
  34       (setf j0 (f2cl-lib:int-add mu 2))
  35       (setf j1
  36               (f2cl-lib:int-sub
  37                (min (the f2cl-lib:integer4 n) (the f2cl-lib:integer4 m))
  38                1))
  39       (if (< j1 j0) (go label30))
  40       (f2cl-lib:fdo (jz j0 (f2cl-lib:int-add jz 1))
  41                     ((> jz j1) nil)
  42         (tagbody
  43           (setf i0 (f2cl-lib:int-sub (f2cl-lib:int-add m 1) jz))
  44           (f2cl-lib:fdo (i i0 (f2cl-lib:int-add i 1))
  45                         ((> i ml) nil)
  46             (tagbody
  47               (setf (f2cl-lib:fref abd-%data%
  48                                    (i jz)
  49                                    ((1 lda) (1 *))
  50                                    abd-%offset%)
  51                       0.0)
  52              label10))
  53          label20))
  54      label30
  55       (setf jz j1)
  56       (setf ju 0)
  57       (setf nm1 (f2cl-lib:int-sub n 1))
  58       (if (< nm1 1) (go label130))
  59       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  60                     ((> k nm1) nil)
  61         (tagbody
  62           (setf kp1 (f2cl-lib:int-add k 1))
  63           (setf jz (f2cl-lib:int-add jz 1))
  64           (if (> jz n) (go label50))
  65           (if (< ml 1) (go label50))
  66           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  67                         ((> i ml) nil)
  68             (tagbody
  69               (setf (f2cl-lib:fref abd-%data%
  70                                    (i jz)
  71                                    ((1 lda) (1 *))
  72                                    abd-%offset%)
  73                       0.0)
  74              label40))
  75          label50
  76           (setf lm
  77                   (min (the f2cl-lib:integer4 ml)
  78                        (the f2cl-lib:integer4 (f2cl-lib:int-sub n k))))
  79           (setf l
  80                   (f2cl-lib:int-sub
  81                    (f2cl-lib:int-add
  82                     (idamax (f2cl-lib:int-add lm 1)
  83                      (f2cl-lib:array-slice abd-%data%
  84                                            double-float
  85                                            (m k)
  86                                            ((1 lda) (1 *))
  87                                            abd-%offset%)
  88                      1)
  89                     m)
  90                    1))
  91           (setf (f2cl-lib:fref ipvt-%data% (k) ((1 *)) ipvt-%offset%)
  92                   (f2cl-lib:int-sub (f2cl-lib:int-add l k) m))
  93           (if
  94            (= (f2cl-lib:fref abd-%data% (l k) ((1 lda) (1 *)) abd-%offset%)
  95               0.0)
  96            (go label100))
  97           (if (= l m) (go label60))
  98           (setf t$
  99                   (f2cl-lib:fref abd-%data%
 100                                  (l k)
 101                                  ((1 lda) (1 *))
 102                                  abd-%offset%))
 103           (setf (f2cl-lib:fref abd-%data% (l k) ((1 lda) (1 *)) abd-%offset%)
 104                   (f2cl-lib:fref abd-%data%
 105                                  (m k)
 106                                  ((1 lda) (1 *))
 107                                  abd-%offset%))
 108           (setf (f2cl-lib:fref abd-%data% (m k) ((1 lda) (1 *)) abd-%offset%)
 109                   t$)
 110          label60
 111           (setf t$
 112                   (/ -1.0
 113                      (f2cl-lib:fref abd-%data%
 114                                     (m k)
 115                                     ((1 lda) (1 *))
 116                                     abd-%offset%)))
 117           (dscal lm t$
 118            (f2cl-lib:array-slice abd-%data%
 119                                  double-float
 120                                  ((+ m 1) k)
 121                                  ((1 lda) (1 *))
 122                                  abd-%offset%)
 123            1)
 124           (setf ju
 125                   (min
 126                    (the f2cl-lib:integer4
 127                         (max (the f2cl-lib:integer4 ju)
 128                              (the f2cl-lib:integer4
 129                                   (f2cl-lib:int-add mu
 130                                                     (f2cl-lib:fref ipvt-%data%
 131                                                                    (k)
 132                                                                    ((1 *))
 133                                                                    ipvt-%offset%)))))
 134                    (the f2cl-lib:integer4 n)))
 135           (setf mm m)
 136           (if (< ju kp1) (go label90))
 137           (f2cl-lib:fdo (j kp1 (f2cl-lib:int-add j 1))
 138                         ((> j ju) nil)
 139             (tagbody
 140               (setf l (f2cl-lib:int-sub l 1))
 141               (setf mm (f2cl-lib:int-sub mm 1))
 142               (setf t$
 143                       (f2cl-lib:fref abd-%data%
 144                                      (l j)
 145                                      ((1 lda) (1 *))
 146                                      abd-%offset%))
 147               (if (= l mm) (go label70))
 148               (setf (f2cl-lib:fref abd-%data%
 149                                    (l j)
 150                                    ((1 lda) (1 *))
 151                                    abd-%offset%)
 152                       (f2cl-lib:fref abd-%data%
 153                                      (mm j)
 154                                      ((1 lda) (1 *))
 155                                      abd-%offset%))
 156               (setf (f2cl-lib:fref abd-%data%
 157                                    (mm j)
 158                                    ((1 lda) (1 *))
 159                                    abd-%offset%)
 160                       t$)
 161              label70
 162               (daxpy lm t$
 163                (f2cl-lib:array-slice abd-%data%
 164                                      double-float
 165                                      ((+ m 1) k)
 166                                      ((1 lda) (1 *))
 167                                      abd-%offset%)
 168                1
 169                (f2cl-lib:array-slice abd-%data%
 170                                      double-float
 171                                      ((+ mm 1) j)
 172                                      ((1 lda) (1 *))
 173                                      abd-%offset%)
 174                1)
 175              label80))
 176          label90
 177           (go label110)
 178          label100
 179           (setf info k)
 180          label110
 181          label120))
 182      label130
 183       (setf (f2cl-lib:fref ipvt-%data% (n) ((1 *)) ipvt-%offset%) n)
 184       (if (= (f2cl-lib:fref abd-%data% (m n) ((1 lda) (1 *)) abd-%offset%) 0.0)
 185           (setf info n))
 186       (go end_label)
 187      end_label
 188       (return (values nil nil nil nil nil nil info)))))
 189
 190 (in-package #:cl-user)
 191 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 192 (eval-when (:load-toplevel :compile-toplevel :execute)
 193   (setf (gethash 'fortran-to-lisp::dgbfa fortran-to-lisp::*f2cl-function-info*)
 194           (fortran-to-lisp::make-f2cl-finfo
 195            :arg-types '((array double-float (*)) (fortran-to-lisp::integer4)
 196                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 197                         (fortran-to-lisp::integer4)
 198                         (array fortran-to-lisp::integer4 (*))
 199                         (fortran-to-lisp::integer4))
 200            :return-values '(nil nil nil nil nil nil fortran-to-lisp::info)
 201            :calls '(fortran-to-lisp::daxpy fortran-to-lisp::dscal
 202                     fortran-to-lisp::idamax))))
 203