share/hompack/lisp/multds.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-2020-04 (21D 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 "HOMPACK")
  18
  19
  20 (defun multds (y aa x maxa nn lenaa)
  21   (declare (type (f2cl-lib:integer4) lenaa nn)
  22            (type (array f2cl-lib:integer4 (*)) maxa)
  23            (type (array double-float (*)) x aa y))
  24   (f2cl-lib:with-multi-array-data
  25       ((y double-float y-%data% y-%offset%)
  26        (aa double-float aa-%data% aa-%offset%)
  27        (x double-float x-%data% x-%offset%)
  28        (maxa f2cl-lib:integer4 maxa-%data% maxa-%offset%))
  29     (prog ((b 0.0) (cc 0.0) (i 0) (ii 0) (kk 0) (kl 0) (ku 0))
  30       (declare (type (f2cl-lib:integer4) ku kl kk ii i)
  31                (type (double-float) cc b))
  32       (if (> lenaa nn) (go label20))
  33       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  34                     ((> i nn) nil)
  35         (tagbody
  36          label10
  37           (setf (f2cl-lib:fref y-%data% (i) ((1 nn)) y-%offset%)
  38                   (* (f2cl-lib:fref aa-%data% (i) ((1 lenaa)) aa-%offset%)
  39                      (f2cl-lib:fref x-%data% (i) ((1 nn)) x-%offset%)))))
  40       (go end_label)
  41      label20
  42       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  43                     ((> i nn) nil)
  44         (tagbody
  45          label40
  46           (setf (f2cl-lib:fref y-%data% (i) ((1 nn)) y-%offset%)
  47                   (coerce 0.0f0 'double-float))))
  48       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  49                     ((> i nn) nil)
  50         (tagbody
  51           (setf kl
  52                   (f2cl-lib:fref maxa-%data%
  53                                  (i)
  54                                  ((1 (f2cl-lib:int-add nn 1)))
  55                                  maxa-%offset%))
  56           (setf ku
  57                   (f2cl-lib:int-sub
  58                    (f2cl-lib:fref maxa-%data%
  59                                   ((f2cl-lib:int-add i 1))
  60                                   ((1 (f2cl-lib:int-add nn 1)))
  61                                   maxa-%offset%)
  62                    1))
  63           (setf ii (f2cl-lib:int-add i 1))
  64           (setf cc (f2cl-lib:fref x-%data% (i) ((1 nn)) x-%offset%))
  65           (f2cl-lib:fdo (kk kl (f2cl-lib:int-add kk 1))
  66                         ((> kk ku) nil)
  67             (tagbody
  68               (setf ii (f2cl-lib:int-sub ii 1))
  69               (setf (f2cl-lib:fref y-%data% (ii) ((1 nn)) y-%offset%)
  70                       (+ (f2cl-lib:fref y-%data% (ii) ((1 nn)) y-%offset%)
  71                          (*
  72                           (f2cl-lib:fref aa-%data%
  73                                          (kk)
  74                                          ((1 lenaa))
  75                                          aa-%offset%)
  76                           cc)))))))
  77      label100
  78       (if (= nn 1) (go end_label))
  79       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  80                     ((> i nn) nil)
  81         (tagbody
  82           (setf kl
  83                   (f2cl-lib:int-add
  84                    (f2cl-lib:fref maxa-%data%
  85                                   (i)
  86                                   ((1 (f2cl-lib:int-add nn 1)))
  87                                   maxa-%offset%)
  88                    1))
  89           (setf ku
  90                   (f2cl-lib:int-sub
  91                    (f2cl-lib:fref maxa-%data%
  92                                   ((f2cl-lib:int-add i 1))
  93                                   ((1 (f2cl-lib:int-add nn 1)))
  94                                   maxa-%offset%)
  95                    1))
  96           (f2cl-lib:arithmetic-if (f2cl-lib:int-sub ku kl)
  97                                   (go label200)
  98                                   (go label210)
  99                                   (go label210))
 100          label210
 101           (setf ii i)
 102           (setf b (coerce 0.0f0 'double-float))
 103           (f2cl-lib:fdo (kk kl (f2cl-lib:int-add kk 1))
 104                         ((> kk ku) nil)
 105             (tagbody
 106               (setf ii (f2cl-lib:int-sub ii 1))
 107              label220
 108               (setf b
 109                       (+ b
 110                          (*
 111                           (f2cl-lib:fref aa-%data%
 112                                          (kk)
 113                                          ((1 lenaa))
 114                                          aa-%offset%)
 115                           (f2cl-lib:fref x-%data%
 116                                          (ii)
 117                                          ((1 nn))
 118                                          x-%offset%))))))
 119           (setf (f2cl-lib:fref y-%data% (i) ((1 nn)) y-%offset%)
 120                   (+ (f2cl-lib:fref y-%data% (i) ((1 nn)) y-%offset%) b))
 121          label200))
 122       (go end_label)
 123      end_label
 124       (return (values nil nil nil nil nil nil)))))
 125
 126 (in-package #:cl-user)
 127 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 128 (eval-when (:load-toplevel :compile-toplevel :execute)
 129   (setf (gethash 'fortran-to-lisp::multds
 130                  fortran-to-lisp::*f2cl-function-info*)
 131           (fortran-to-lisp::make-f2cl-finfo
 132            :arg-types '((array double-float (*)) (array double-float (*))
 133                         (array double-float (*))
 134                         (array fortran-to-lisp::integer4 (*))
 135                         (fortran-to-lisp::integer4)
 136                         (fortran-to-lisp::integer4))
 137            :return-values '(nil nil nil nil nil nil)
 138            :calls 'nil)))
 139