share/odepack/src/dorthog.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 dorthog (vnew v hes n ll ldhes kmp snormw)
  21   (declare (type (double-float) snormw)
  22            (type (f2cl-lib:integer4) kmp ldhes ll n)
  23            (type (array double-float (*)) hes v vnew))
  24   (f2cl-lib:with-multi-array-data
  25       ((vnew double-float vnew-%data% vnew-%offset%)
  26        (v double-float v-%data% v-%offset%)
  27        (hes double-float hes-%data% hes-%offset%))
  28     (prog ((arg 0.0d0) (sumdsq 0.0d0) (tem 0.0d0) (vnrm 0.0d0) (i 0) (i0 0))
  29       (declare (type (f2cl-lib:integer4) i0 i)
  30                (type (double-float) vnrm tem sumdsq arg))
  31       (setf vnrm (dnrm2 n vnew 1))
  32       (setf i0
  33               (max (the f2cl-lib:integer4 1)
  34                    (the f2cl-lib:integer4
  35                         (f2cl-lib:int-add (f2cl-lib:int-sub ll kmp) 1))))
  36       (f2cl-lib:fdo (i i0 (f2cl-lib:int-add i 1))
  37                     ((> i ll) nil)
  38         (tagbody
  39           (setf (f2cl-lib:fref hes-%data%
  40                                (i ll)
  41                                ((1 ldhes) (1 *))
  42                                hes-%offset%)
  43                   (ddot n
  44                    (f2cl-lib:array-slice v-%data%
  45                                          double-float
  46                                          (1 i)
  47                                          ((1 n) (1 *))
  48                                          v-%offset%)
  49                    1 vnew 1))
  50           (setf tem
  51                   (-
  52                    (f2cl-lib:fref hes-%data%
  53                                   (i ll)
  54                                   ((1 ldhes) (1 *))
  55                                   hes-%offset%)))
  56           (daxpy n tem
  57            (f2cl-lib:array-slice v-%data%
  58                                  double-float
  59                                  (1 i)
  60                                  ((1 n) (1 *))
  61                                  v-%offset%)
  62            1 vnew 1)
  63          label10))
  64       (setf snormw (dnrm2 n vnew 1))
  65       (if (/= (+ vnrm (* 0.001d0 snormw)) vnrm) (go end_label))
  66       (setf sumdsq 0.0d0)
  67       (f2cl-lib:fdo (i i0 (f2cl-lib:int-add i 1))
  68                     ((> i ll) nil)
  69         (tagbody
  70           (setf tem
  71                   (-
  72                    (ddot n
  73                     (f2cl-lib:array-slice v-%data%
  74                                           double-float
  75                                           (1 i)
  76                                           ((1 n) (1 *))
  77                                           v-%offset%)
  78                     1 vnew 1)))
  79           (if
  80            (=
  81             (+ (f2cl-lib:fref hes-%data% (i ll) ((1 ldhes) (1 *)) hes-%offset%)
  82                (* 0.001d0 tem))
  83             (f2cl-lib:fref hes-%data% (i ll) ((1 ldhes) (1 *)) hes-%offset%))
  84            (go label30))
  85           (setf (f2cl-lib:fref hes-%data%
  86                                (i ll)
  87                                ((1 ldhes) (1 *))
  88                                hes-%offset%)
  89                   (-
  90                    (f2cl-lib:fref hes-%data%
  91                                   (i ll)
  92                                   ((1 ldhes) (1 *))
  93                                   hes-%offset%)
  94                    tem))
  95           (daxpy n tem
  96            (f2cl-lib:array-slice v-%data%
  97                                  double-float
  98                                  (1 i)
  99                                  ((1 n) (1 *))
 100                                  v-%offset%)
 101            1 vnew 1)
 102           (setf sumdsq (+ sumdsq (expt tem 2)))
 103          label30))
 104       (if (= sumdsq 0.0d0) (go end_label))
 105       (setf arg (max 0.0d0 (- (expt snormw 2) sumdsq)))
 106       (setf snormw (f2cl-lib:fsqrt arg))
 107       (go end_label)
 108      end_label
 109       (return (values nil nil nil nil nil nil nil snormw)))))
 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::dorthog
 115                  fortran-to-lisp::*f2cl-function-info*)
 116           (fortran-to-lisp::make-f2cl-finfo
 117            :arg-types '((array double-float (*)) (array double-float (*))
 118                         (array double-float (*)) (fortran-to-lisp::integer4)
 119                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 120                         (fortran-to-lisp::integer4) (double-float))
 121            :return-values '(nil nil nil nil nil nil nil
 122                             fortran-to-lisp::snormw)
 123            :calls '(fortran-to-lisp::daxpy fortran-to-lisp::ddot
 124                     fortran-to-lisp::dnrm2))))
 125