share/odepack/src/dnrm2.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 (let ((zero 0.0d0) (one 1.0d0) (cutlo 8.232d-11) (cuthi 1.304d19))
  21   (declare (type (double-float) zero one cutlo cuthi))
  22   (defun dnrm2 (n dx incx)
  23     (declare (type (array double-float (*)) dx)
  24              (type (f2cl-lib:integer4) incx n))
  25     (f2cl-lib:with-multi-array-data
  26         ((dx double-float dx-%data% dx-%offset%))
  27       (prog ((hitest 0.0d0) (sum 0.0d0) (xmax 0.0d0) (next 0) (dnrm2 0.0d0)
  28              (j 0) (i 0) (nn 0))
  29         (declare (type (f2cl-lib:integer4) nn i j next)
  30                  (type (double-float) dnrm2 xmax sum hitest))
  31         (if (> n 0) (go label10))
  32         (setf dnrm2 zero)
  33         (go label300)
  34        label10
  35         (setf next 30)
  36         (setf sum zero)
  37         (setf nn (f2cl-lib:int-mul n incx))
  38         (setf i 1)
  39        label20
  40         (f2cl-lib:assigned-goto next (30 50 70 110))
  41        label30
  42         (if (> (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) cutlo)
  43             (go label85))
  44         (setf next 50)
  45         (setf xmax zero)
  46        label50
  47         (if (= (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) zero)
  48             (go label200))
  49         (if (> (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) cutlo)
  50             (go label85))
  51         (setf next 70)
  52         (go label105)
  53        label100
  54         (setf i j)
  55         (setf next 110)
  56         (setf sum
  57                 (/ (/ sum (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))
  58                    (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))
  59        label105
  60         (setf xmax (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))
  61         (go label115)
  62        label70
  63         (if (> (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) cutlo)
  64             (go label75))
  65        label110
  66         (if (<= (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) xmax)
  67             (go label115))
  68         (setf sum
  69                 (+ one
  70                    (* sum
  71                       (expt
  72                        (/ xmax
  73                           (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))
  74                        2))))
  75         (setf xmax (abs (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))
  76         (go label200)
  77        label115
  78         (setf sum
  79                 (+ sum
  80                    (expt
  81                     (/ (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) xmax)
  82                     2)))
  83         (go label200)
  84        label75
  85         (setf sum (* sum xmax xmax))
  86        label85
  87         (setf hitest (/ cuthi n))
  88         (f2cl-lib:fdo (j i (f2cl-lib:int-add j incx))
  89                       ((> j nn) nil)
  90           (tagbody
  91             (if
  92              (>= (abs (f2cl-lib:fref dx-%data% (j) ((1 *)) dx-%offset%))
  93                  hitest)
  94              (go label100))
  95            label95
  96             (setf sum
  97                     (+ sum
  98                        (expt (f2cl-lib:fref dx-%data% (j) ((1 *)) dx-%offset%)
  99                              2)))))
 100         (setf dnrm2 (f2cl-lib:fsqrt sum))
 101         (go label300)
 102        label200
 103         (setf i (f2cl-lib:int-add i incx))
 104         (if (<= i nn) (go label20))
 105         (setf dnrm2 (* xmax (f2cl-lib:fsqrt sum)))
 106        label300
 107         (go end_label)
 108        end_label
 109         (return (values dnrm2 nil nil nil))))))
 110
 111 (in-package #:cl-user)
 112 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 113 (eval-when (:load-toplevel :compile-toplevel :execute)
 114   (setf (gethash 'fortran-to-lisp::dnrm2 fortran-to-lisp::*f2cl-function-info*)
 115           (fortran-to-lisp::make-f2cl-finfo
 116            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 117                         (fortran-to-lisp::integer4))
 118            :return-values '(nil nil nil)
 119            :calls 'nil)))
 120