share/colnew/lisp/rkbas.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 1.221 2010/05/26 19:25:52 rtoy Exp $"
   3 ;;;  "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $"
   4 ;;;  "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $"
   5 ;;;  "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $"
   6 ;;;  "f2cl5.l,v 1.204 2010/02/23 05:21:30 rtoy Exp $"
   7 ;;;  "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $"
   8 ;;;  "macros.l,v 1.114 2010/05/17 01:42:14 rtoy Exp $")
   9
  10 ;;; Using Lisp CMU Common Lisp CVS Head 2010-05-25 18:21:07 (20A 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 :colnew)
  18
  19
  20 (defun rkbas (s coef k m rkb dm mode)
  21   (declare (type (array double-float (*)) dm)
  22            (type (array double-float (*)) rkb)
  23            (type (f2cl-lib:integer4) mode m k)
  24            (type (array double-float (*)) coef)
  25            (type double-float s))
  26   (f2cl-lib:with-multi-array-data
  27       ((coef double-float coef-%data% coef-%offset%)
  28        (rkb double-float rkb-%data% rkb-%offset%)
  29        (dm double-float dm-%data% dm-%offset%))
  30     (prog ((t$ (make-array 10 :element-type 'double-float)) (j 0) (p 0.0)
  31            (lb 0) (l 0) (i 0) (kpm1 0))
  32       (declare (type double-float p)
  33                (type (f2cl-lib:integer4) kpm1 i l lb j)
  34                (type (array double-float (10)) t$))
  35       (if (= k 1) (go label70))
  36       (setf kpm1 (f2cl-lib:int-sub (f2cl-lib:int-add k m) 1))
  37       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  38                     ((> i kpm1) nil)
  39         (tagbody
  40          label10
  41           (setf (f2cl-lib:fref t$ (i) ((1 10))) (/ s (f2cl-lib:dfloat i)))))
  42       (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
  43                     ((> l m) nil)
  44         (tagbody
  45           (setf lb (f2cl-lib:int-add k l 1))
  46           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  47                         ((> i k) nil)
  48             (tagbody
  49               (setf p
  50                       (f2cl-lib:fref coef-%data%
  51                                      (1 i)
  52                                      ((1 k) (1 1))
  53                                      coef-%offset%))
  54               (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
  55                             ((> j k) nil)
  56                 (tagbody
  57                   (setf p
  58                           (+
  59                            (* p
  60                               (f2cl-lib:fref t$
  61                                              ((f2cl-lib:int-sub lb j))
  62                                              ((1 10))))
  63                            (f2cl-lib:fref coef-%data%
  64                                           (j i)
  65                                           ((1 k) (1 1))
  66                                           coef-%offset%)))
  67                  label20))
  68               (setf (f2cl-lib:fref rkb-%data% (i l) ((1 7) (1 1)) rkb-%offset%)
  69                       p)
  70              label30))
  71          label40))
  72       (if (= mode 0) (go end_label))
  73       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  74                     ((> i k) nil)
  75         (tagbody
  76           (setf p
  77                   (f2cl-lib:fref coef-%data%
  78                                  (1 i)
  79                                  ((1 k) (1 1))
  80                                  coef-%offset%))
  81           (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
  82                         ((> j k) nil)
  83             (tagbody
  84              label50
  85               (setf p
  86                       (+
  87                        (* p
  88                           (f2cl-lib:fref t$
  89                                          ((f2cl-lib:int-sub
  90                                            (f2cl-lib:int-add k 1)
  91                                            j))
  92                                          ((1 10))))
  93                        (f2cl-lib:fref coef-%data%
  94                                       (j i)
  95                                       ((1 k) (1 1))
  96                                       coef-%offset%)))))
  97           (setf (f2cl-lib:fref dm-%data% (i) ((1 1)) dm-%offset%) p)
  98          label60))
  99       (go end_label)
 100      label70
 101       (setf (f2cl-lib:fref rkb-%data% (1 1) ((1 7) (1 1)) rkb-%offset%) 1.0)
 102       (setf (f2cl-lib:fref dm-%data% (1) ((1 1)) dm-%offset%) 1.0)
 103       (go end_label)
 104      end_label
 105       (return (values nil nil nil nil nil nil nil)))))
 106
 107 (in-package #:cl-user)
 108 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 109 (eval-when (:load-toplevel :compile-toplevel :execute)
 110   (setf (gethash 'fortran-to-lisp::rkbas fortran-to-lisp::*f2cl-function-info*)
 111           (fortran-to-lisp::make-f2cl-finfo
 112            :arg-types '(double-float (array double-float (*))
 113                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 114                         (array double-float (7)) (array double-float (1))
 115                         (fortran-to-lisp::integer4))
 116            :return-values '(nil nil nil nil nil nil nil)
 117            :calls 'nil)))
 118