share/odepack/src/dpcgs.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 dpcgs
  21        (neq tn y savf r wght n maxl delta hl0 jpre mnewt f psol npsl x p w z
  22         lpcg wp iwp wk iflag)
  23   (declare (type (f2cl-lib:integer4) iflag lpcg npsl mnewt jpre maxl n)
  24            (type (array double-float (*)) wk wp z w p x wght r savf y)
  25            (type (double-float) hl0 delta tn)
  26            (type (array f2cl-lib:integer4 (*)) iwp neq))
  27   (f2cl-lib:with-multi-array-data
  28       ((neq f2cl-lib:integer4 neq-%data% neq-%offset%)
  29        (iwp f2cl-lib:integer4 iwp-%data% iwp-%offset%)
  30        (y double-float y-%data% y-%offset%)
  31        (savf double-float savf-%data% savf-%offset%)
  32        (r double-float r-%data% r-%offset%)
  33        (wght double-float wght-%data% wght-%offset%)
  34        (x double-float x-%data% x-%offset%)
  35        (p double-float p-%data% p-%offset%)
  36        (w double-float w-%data% w-%offset%)
  37        (z double-float z-%data% z-%offset%)
  38        (wp double-float wp-%data% wp-%offset%)
  39        (wk double-float wk-%data% wk-%offset%))
  40     (prog ((alpha 0.0d0) (beta 0.0d0) (bnrm 0.0d0) (ptw 0.0d0) (rnrm 0.0d0)
  41            (ztr 0.0d0) (ztr0 0.0d0) (i 0) (ier 0))
  42       (declare (type (f2cl-lib:integer4) ier i)
  43                (type (double-float) ztr0 ztr rnrm ptw bnrm beta alpha))
  44       (setf iflag 0)
  45       (setf npsl 0)
  46       (setf lpcg 0)
  47       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  48                     ((> i n) nil)
  49         (tagbody
  50          label10
  51           (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) 0.0d0)))
  52       (setf bnrm (dvnorm n r wght))
  53       (if (> bnrm delta) (go label20))
  54       (if (> mnewt 0) (go end_label))
  55       (dcopy n r 1 x 1)
  56       (go end_label)
  57      label20
  58       (setf ztr 0.0d0)
  59      label30
  60       (setf lpcg (f2cl-lib:int-add lpcg 1))
  61       (dcopy n r 1 z 1)
  62       (setf ier 0)
  63       (if (= jpre 0) (go label40))
  64       (multiple-value-bind
  65             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  66              var-10)
  67           (funcall psol neq tn y savf wk hl0 wp iwp z 3 ier)
  68         (declare (ignore var-0 var-2 var-3 var-4 var-6 var-7 var-8 var-9))
  69         (when var-1
  70           (setf tn var-1))
  71         (when var-5
  72           (setf hl0 var-5))
  73         (when var-10
  74           (setf ier var-10)))
  75       (setf npsl (f2cl-lib:int-add npsl 1))
  76       (if (/= ier 0) (go label100))
  77      label40
  78       (setf ztr0 ztr)
  79       (setf ztr 0.0d0)
  80       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  81                     ((> i n) nil)
  82         (tagbody
  83          label45
  84           (setf ztr
  85                   (+ ztr
  86                      (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
  87                         (f2cl-lib:fref r-%data% (i) ((1 *)) r-%offset%)
  88                         (expt
  89                          (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)
  90                          2))))))
  91       (if (/= lpcg 1) (go label50))
  92       (dcopy n z 1 p 1)
  93       (go label70)
  94      label50
  95       (if (= ztr0 0.0d0) (go label200))
  96       (setf beta (/ ztr ztr0))
  97       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  98                     ((> i n) nil)
  99         (tagbody
 100          label60
 101           (setf (f2cl-lib:fref p-%data% (i) ((1 *)) p-%offset%)
 102                   (+ (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)
 103                      (* beta
 104                         (f2cl-lib:fref p-%data% (i) ((1 *)) p-%offset%))))))
 105      label70
 106       (datp neq y savf p wght hl0 wk f w)
 107       (setf ptw 0.0d0)
 108       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 109                     ((> i n) nil)
 110         (tagbody
 111          label80
 112           (setf ptw
 113                   (+ ptw
 114                      (* (f2cl-lib:fref p-%data% (i) ((1 *)) p-%offset%)
 115                         (f2cl-lib:fref w-%data% (i) ((1 *)) w-%offset%)
 116                         (expt
 117                          (f2cl-lib:fref wght-%data% (i) ((1 *)) wght-%offset%)
 118                          2))))))
 119       (if (= ptw 0.0d0) (go label200))
 120       (setf alpha (/ ztr ptw))
 121       (daxpy n alpha p 1 x 1)
 122       (setf alpha (- alpha))
 123       (daxpy n alpha w 1 r 1)
 124       (setf rnrm (dvnorm n r wght))
 125       (if (<= rnrm delta) (go end_label))
 126       (if (< lpcg maxl) (go label30))
 127       (setf iflag 2)
 128       (if (<= rnrm 1.0d0) (setf iflag 1))
 129       (if (and (<= rnrm bnrm) (= mnewt 0)) (setf iflag 1))
 130       (go end_label)
 131      label100
 132       (if (< ier 0) (setf iflag -1))
 133       (if (> ier 0) (setf iflag 3))
 134       (go end_label)
 135      label200
 136       (setf iflag 4)
 137       (go end_label)
 138      end_label
 139       (return
 140        (values nil
 141                tn
 142                nil
 143                nil
 144                nil
 145                nil
 146                nil
 147                nil
 148                nil
 149                hl0
 150                nil
 151                nil
 152                nil
 153                nil
 154                npsl
 155                nil
 156                nil
 157                nil
 158                nil
 159                lpcg
 160                nil
 161                nil
 162                nil
 163                iflag)))))
 164
 165 (in-package #:cl-user)
 166 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 167 (eval-when (:load-toplevel :compile-toplevel :execute)
 168   (setf (gethash 'fortran-to-lisp::dpcgs fortran-to-lisp::*f2cl-function-info*)
 169           (fortran-to-lisp::make-f2cl-finfo
 170            :arg-types '((array fortran-to-lisp::integer4 (*)) (double-float)
 171                         (array double-float (*)) (array double-float (*))
 172                         (array double-float (*)) (array double-float (*))
 173                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 174                         (double-float) (double-float)
 175                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 176                         t t (fortran-to-lisp::integer4)
 177                         (array double-float (*)) (array double-float (*))
 178                         (array double-float (*)) (array double-float (*))
 179                         (fortran-to-lisp::integer4) (array double-float (*))
 180                         (array fortran-to-lisp::integer4 (*))
 181                         (array double-float (*)) (fortran-to-lisp::integer4))
 182            :return-values '(nil fortran-to-lisp::tn nil nil nil nil nil nil nil
 183                             fortran-to-lisp::hl0 nil nil nil nil
 184                             fortran-to-lisp::npsl nil nil nil nil
 185                             fortran-to-lisp::lpcg nil nil nil
 186                             fortran-to-lisp::iflag)
 187            :calls '(fortran-to-lisp::daxpy fortran-to-lisp::datp
 188                     fortran-to-lisp::dcopy fortran-to-lisp::dvnorm))))
 189