share/odepack/src/dspigmr.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 dspigmr
  21        (neq tn y savf b wght n maxl maxlp1 kmp delta hl0 jpre mnewt f psol npsl
  22         x v hes q lgmr wp iwp wk dl iflag)
  23   (declare (type (f2cl-lib:integer4) iflag lgmr npsl mnewt jpre kmp maxlp1 maxl
  24                                      n)
  25            (type (array double-float (*)) dl wk wp q hes v x wght b savf y)
  26            (type (double-float) hl0 delta tn)
  27            (type (array f2cl-lib:integer4 (*)) iwp neq))
  28   (f2cl-lib:with-multi-array-data
  29       ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  30        (iwp f2cl-lib:integer4 iwp-%data% iwp-%offset%)
  31        (y double-float y-%data% y-%offset%)
  32        (savf double-float savf-%data% savf-%offset%)
  33        (b double-float b-%data% b-%offset%)
  34        (wght double-float wght-%data% wght-%offset%)
  35        (x double-float x-%data% x-%offset%)
  36        (v double-float v-%data% v-%offset%)
  37        (hes double-float hes-%data% hes-%offset%)
  38        (q double-float q-%data% q-%offset%)
  39        (wp double-float wp-%data% wp-%offset%)
  40        (wk double-float wk-%data% wk-%offset%)
  41        (dl double-float dl-%data% dl-%offset%))
  42     (prog ((bnrm 0.0d0) (bnrm0 0.0d0) (c 0.0d0) (dlnrm 0.0d0) (prod 0.0d0)
  43            (rho 0.0d0) (s 0.0d0) (snormw 0.0d0) (tem 0.0d0) (i 0) (ier 0)
  44            (info 0) (ip1 0) (i2 0) (j 0) (k 0) (ll 0) (llp1 0))
  45       (declare (type (f2cl-lib:integer4) llp1 ll k j i2 ip1 info ier i)
  46                (type (double-float) tem snormw s rho prod dlnrm c bnrm0 bnrm))
  47       (setf iflag 0)
  48       (setf lgmr 0)
  49       (setf npsl 0)
  50       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  51                     ((> i n) nil)
  52         (tagbody
  53          label10
  54           (setf (f2cl-lib:fref v-%data% (i 1) ((1 n) (1 *)) v-%offset%)
  55                   (* (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
  56                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
  57       (setf bnrm0 (dnrm2 n v 1))
  58       (setf bnrm bnrm0)
  59       (if (> bnrm0 delta) (go label30))
  60       (if (> mnewt 0) (go label20))
  61       (dcopy n b 1 x 1)
  62       (go end_label)
  63      label20
  64       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  65                     ((> i n) nil)
  66         (tagbody
  67          label25
  68           (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) 0.0d0)))
  69       (go end_label)
  70      label30
  71       (setf ier 0)
  72       (if (or (= jpre 0) (= jpre 2)) (go label55))
  73       (multiple-value-bind
  74             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  75              var-10)
  76           (funcall psol neq tn y savf wk hl0 wp iwp b 1 ier)
  77         (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
  78         (when var-1
  79           (setf tn var-1))
  80         (when var-5
  81           (setf hl0 var-5))
  82         (when var-10
  83           (setf ier var-10)))
  84       (setf npsl 1)
  85       (if (/= ier 0) (go label300))
  86       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  87                     ((> i n) nil)
  88         (tagbody
  89          label50
  90           (setf (f2cl-lib:fref v-%data% (i 1) ((1 n) (1 *)) v-%offset%)
  91                   (* (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
  92                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
  93       (setf bnrm (dnrm2 n v 1))
  94       (setf delta (* delta (/ bnrm bnrm0)))
  95      label55
  96       (setf tem (/ 1.0d0 bnrm))
  97       (dscal n tem
  98        (f2cl-lib:array-slice v-%data%
  99                              double-float
 100                              (1 1)
 101                              ((1 n) (1 *))
 102                              v-%offset%)
 103        1)
 104       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 105                     ((> j maxl) nil)
 106         (tagbody
 107           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 108                         ((> i maxlp1) nil)
 109             (tagbody
 110              label60
 111               (setf (f2cl-lib:fref hes-%data%
 112                                    (i j)
 113                                    ((1 maxlp1) (1 *))
 114                                    hes-%offset%)
 115                       0.0d0)))
 116          label65))
 117       (setf prod 1.0d0)
 118       (f2cl-lib:fdo (ll 1 (f2cl-lib:int-add ll 1))
 119                     ((> ll maxl) nil)
 120         (tagbody
 121           (setf lgmr ll)
 122           (multiple-value-bind
 123                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 124                  var-10 var-11 var-12 var-13 var-14 var-15)
 125               (datv neq y savf
 126                (f2cl-lib:array-slice v-%data%
 127                                      double-float
 128                                      (1 ll)
 129                                      ((1 n) (1 *))
 130                                      v-%offset%)
 131                wght x f psol
 132                (f2cl-lib:array-slice v-%data%
 133                                      double-float
 134                                      (1 (f2cl-lib:int-add ll 1))
 135                                      ((1 n) (1 *))
 136                                      v-%offset%)
 137                wk wp iwp hl0 jpre ier npsl)
 138             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
 139                              var-8 var-9 var-10 var-11 var-13))
 140             (setf hl0 var-12)
 141             (setf ier var-14)
 142             (setf npsl var-15))
 143           (if (/= ier 0) (go label300))
 144           (multiple-value-bind
 145                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 146               (dorthog
 147                (f2cl-lib:array-slice v-%data%
 148                                      double-float
 149                                      (1 (f2cl-lib:int-add ll 1))
 150                                      ((1 n) (1 *))
 151                                      v-%offset%)
 152                v hes n ll maxlp1 kmp snormw)
 153             (declare (ignore var-0 var-1 var-2))
 154             (when var-3
 155               (setf n var-3))
 156             (when var-4
 157               (setf ll var-4))
 158             (when var-5
 159               (setf maxlp1 var-5))
 160             (when var-6
 161               (setf kmp var-6))
 162             (when var-7
 163               (setf snormw var-7)))
 164           (setf (f2cl-lib:fref hes-%data%
 165                                ((f2cl-lib:int-add ll 1) ll)
 166                                ((1 maxlp1) (1 *))
 167                                hes-%offset%)
 168                   snormw)
 169           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 170               (dheqr hes maxlp1 ll q info ll)
 171             (declare (ignore var-0 var-1 var-2 var-3 var-5))
 172             (setf info var-4))
 173           (if (= info ll) (go label120))
 174           (setf prod
 175                   (* prod
 176                      (f2cl-lib:fref q-%data%
 177                                     ((f2cl-lib:int-mul 2 ll))
 178                                     ((1 *))
 179                                     q-%offset%)))
 180           (setf rho (abs (* prod bnrm)))
 181           (cond
 182             ((and (> ll kmp) (< kmp maxl))
 183              (cond
 184                ((= ll (f2cl-lib:int-add kmp 1))
 185                 (dcopy n
 186                  (f2cl-lib:array-slice v-%data%
 187                                        double-float
 188                                        (1 1)
 189                                        ((1 n) (1 *))
 190                                        v-%offset%)
 191                  1 dl 1)
 192                 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 193                               ((> i kmp) nil)
 194                   (tagbody
 195                     (setf ip1 (f2cl-lib:int-add i 1))
 196                     (setf i2 (f2cl-lib:int-mul i 2))
 197                     (setf s (f2cl-lib:fref q-%data% (i2) ((1 *)) q-%offset%))
 198                     (setf c
 199                             (f2cl-lib:fref q-%data%
 200                                            ((f2cl-lib:int-sub i2 1))
 201                                            ((1 *))
 202                                            q-%offset%))
 203                     (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 204                                   ((> k n) nil)
 205                       (tagbody
 206                        label70
 207                         (setf (f2cl-lib:fref dl-%data% (k) ((1 *)) dl-%offset%)
 208                                 (+
 209                                  (* s
 210                                     (f2cl-lib:fref dl-%data%
 211                                                    (k)
 212                                                    ((1 *))
 213                                                    dl-%offset%))
 214                                  (* c
 215                                     (f2cl-lib:fref v-%data%
 216                                                    (k ip1)
 217                                                    ((1 n) (1 *))
 218                                                    v-%offset%))))))
 219                    label75))))
 220              (setf s
 221                      (f2cl-lib:fref q-%data%
 222                                     ((f2cl-lib:int-mul 2 ll))
 223                                     ((1 *))
 224                                     q-%offset%))
 225              (setf c
 226                      (/
 227                       (f2cl-lib:fref q-%data%
 228                                      ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 ll)
 229                                                         1))
 230                                      ((1 *))
 231                                      q-%offset%)
 232                       snormw))
 233              (setf llp1 (f2cl-lib:int-add ll 1))
 234              (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 235                            ((> k n) nil)
 236                (tagbody
 237                 label80
 238                  (setf (f2cl-lib:fref dl-%data% (k) ((1 *)) dl-%offset%)
 239                          (+
 240                           (* s
 241                              (f2cl-lib:fref dl-%data% (k) ((1 *)) dl-%offset%))
 242                           (* c
 243                              (f2cl-lib:fref v-%data%
 244                                             (k llp1)
 245                                             ((1 n) (1 *))
 246                                             v-%offset%))))))
 247              (setf dlnrm (dnrm2 n dl 1))
 248              (setf rho (* rho dlnrm))))
 249           (if (<= rho delta) (go label200))
 250           (if (= ll maxl) (go label100))
 251           (setf tem (/ 1.0d0 snormw))
 252           (dscal n tem
 253            (f2cl-lib:array-slice v-%data%
 254                                  double-float
 255                                  (1 (f2cl-lib:int-add ll 1))
 256                                  ((1 n) (1 *))
 257                                  v-%offset%)
 258            1)
 259          label90))
 260      label100
 261       (if (<= rho 1.0d0) (go label150))
 262       (if (and (<= rho bnrm) (= mnewt 0)) (go label150))
 263      label120
 264       (setf iflag 2)
 265       (go end_label)
 266      label150
 267       (setf iflag 1)
 268      label200
 269       (setf ll lgmr)
 270       (setf llp1 (f2cl-lib:int-add ll 1))
 271       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 272                     ((> k llp1) nil)
 273         (tagbody
 274          label210
 275           (setf (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%) 0.0d0)))
 276       (setf (f2cl-lib:fref b-%data% (1) ((1 *)) b-%offset%) bnrm)
 277       (dhels hes maxlp1 ll q b)
 278       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 279                     ((> k n) nil)
 280         (tagbody
 281          label220
 282           (setf (f2cl-lib:fref x-%data% (k) ((1 *)) x-%offset%) 0.0d0)))
 283       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 284                     ((> i ll) nil)
 285         (tagbody
 286           (daxpy n (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%)
 287            (f2cl-lib:array-slice v-%data%
 288                                  double-float
 289                                  (1 i)
 290                                  ((1 n) (1 *))
 291                                  v-%offset%)
 292            1 x 1)
 293          label230))
 294       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 295                     ((> i n) nil)
 296         (tagbody
 297          label240
 298           (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
 299                   (/ (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
 300                      (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)))))
 301       (if (<= jpre 1) (go end_label))
 302       (multiple-value-bind
 303             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 304              var-10)
 305           (funcall psol neq tn y savf wk hl0 wp iwp x 2 ier)
 306         (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
 307         (when var-1
 308           (setf tn var-1))
 309         (when var-5
 310           (setf hl0 var-5))
 311         (when var-10
 312           (setf ier var-10)))
 313       (setf npsl (f2cl-lib:int-add npsl 1))
 314       (if (/= ier 0) (go label300))
 315       (go end_label)
 316      label300
 317       (if (< ier 0) (setf iflag -1))
 318       (if (> ier 0) (setf iflag 3))
 319       (go end_label)
 320      end_label
 321       (return
 322        (values nil
 323                tn
 324                nil
 325                nil
 326                nil
 327                nil
 328                n
 329                nil
 330                maxlp1
 331                kmp
 332                delta
 333                hl0
 334                nil
 335                nil
 336                nil
 337                nil
 338                npsl
 339                nil
 340                nil
 341                nil
 342                nil
 343                lgmr
 344                nil
 345                nil
 346                nil
 347                nil
 348                iflag)))))
 349
 350 (in-package #:cl-user)
 351 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 352 (eval-when (:load-toplevel :compile-toplevel :execute)
 353   (setf (gethash 'fortran-to-lisp::dspigmr
 354                  fortran-to-lisp::*f2cl-function-info*)
 355           (fortran-to-lisp::make-f2cl-finfo
 356            :arg-types '((array fortran-to-lisp::integer4 (*)) (double-float)
 357                         (array double-float (*)) (array double-float (*))
 358                         (array double-float (*)) (array double-float (*))
 359                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 360                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 361                         (double-float) (double-float)
 362                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 363                         t t (fortran-to-lisp::integer4)
 364                         (array double-float (*)) (array double-float (*))
 365                         (array double-float (*)) (array double-float (*))
 366                         (fortran-to-lisp::integer4) (array double-float (*))
 367                         (array fortran-to-lisp::integer4 (*))
 368                         (array double-float (*)) (array double-float (*))
 369                         (fortran-to-lisp::integer4))
 370            :return-values '(nil fortran-to-lisp::tn nil nil nil nil
 371                             fortran-to-lisp::n nil fortran-to-lisp::maxlp1
 372                             fortran-to-lisp::kmp fortran-to-lisp::delta
 373                             fortran-to-lisp::hl0 nil nil nil nil
 374                             fortran-to-lisp::npsl nil nil nil nil
 375                             fortran-to-lisp::lgmr nil nil nil nil
 376                             fortran-to-lisp::iflag)
 377            :calls '(fortran-to-lisp::daxpy fortran-to-lisp::dhels
 378                     fortran-to-lisp::dheqr fortran-to-lisp::datv
 379                     fortran-to-lisp::dscal fortran-to-lisp::dcopy
 380                     fortran-to-lisp::dnrm2))))
 381