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