src/numerical/slatec/dgtsl.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   3 ;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   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 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C 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 :slatec)
  18
  19
  20 (defun dgtsl (n c d e b info)
  21   (declare (type (array double-float (*)) b e d c)
  22            (type (f2cl-lib:integer4) info n))
  23   (f2cl-lib:with-multi-array-data
  24       ((c double-float c-%data% c-%offset%)
  25        (d double-float d-%data% d-%offset%)
  26        (e double-float e-%data% e-%offset%)
  27        (b double-float b-%data% b-%offset%))
  28     (prog ((t$ 0.0) (k 0) (kb 0) (kp1 0) (nm1 0) (nm2 0))
  29       (declare (type (f2cl-lib:integer4) nm2 nm1 kp1 kb k)
  30                (type (double-float) t$))
  31       (setf info 0)
  32       (setf (f2cl-lib:fref c-%data% (1) ((1 *)) c-%offset%)
  33               (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))
  34       (setf nm1 (f2cl-lib:int-sub n 1))
  35       (if (< nm1 1) (go label40))
  36       (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)
  37               (f2cl-lib:fref e-%data% (1) ((1 *)) e-%offset%))
  38       (setf (f2cl-lib:fref e-%data% (1) ((1 *)) e-%offset%) 0.0)
  39       (setf (f2cl-lib:fref e-%data% (n) ((1 *)) e-%offset%) 0.0)
  40       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  41                     ((> k nm1) nil)
  42         (tagbody
  43           (setf kp1 (f2cl-lib:int-add k 1))
  44           (if
  45            (< (abs (f2cl-lib:fref c-%data% (kp1) ((1 *)) c-%offset%))
  46               (abs (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%)))
  47            (go label10))
  48           (setf t$ (f2cl-lib:fref c-%data% (kp1) ((1 *)) c-%offset%))
  49           (setf (f2cl-lib:fref c-%data% (kp1) ((1 *)) c-%offset%)
  50                   (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%))
  51           (setf (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%) t$)
  52           (setf t$ (f2cl-lib:fref d-%data% (kp1) ((1 *)) d-%offset%))
  53           (setf (f2cl-lib:fref d-%data% (kp1) ((1 *)) d-%offset%)
  54                   (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%))
  55           (setf (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%) t$)
  56           (setf t$ (f2cl-lib:fref e-%data% (kp1) ((1 *)) e-%offset%))
  57           (setf (f2cl-lib:fref e-%data% (kp1) ((1 *)) e-%offset%)
  58                   (f2cl-lib:fref e-%data% (k) ((1 *)) e-%offset%))
  59           (setf (f2cl-lib:fref e-%data% (k) ((1 *)) e-%offset%) t$)
  60           (setf t$ (f2cl-lib:fref b-%data% (kp1) ((1 *)) b-%offset%))
  61           (setf (f2cl-lib:fref b-%data% (kp1) ((1 *)) b-%offset%)
  62                   (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%))
  63           (setf (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%) t$)
  64          label10
  65           (if (/= (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%) 0.0)
  66               (go label20))
  67           (setf info k)
  68           (go label100)
  69          label20
  70           (setf t$
  71                   (/ (- (f2cl-lib:fref c-%data% (kp1) ((1 *)) c-%offset%))
  72                      (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%)))
  73           (setf (f2cl-lib:fref c-%data% (kp1) ((1 *)) c-%offset%)
  74                   (+ (f2cl-lib:fref d-%data% (kp1) ((1 *)) d-%offset%)
  75                      (* t$ (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%))))
  76           (setf (f2cl-lib:fref d-%data% (kp1) ((1 *)) d-%offset%)
  77                   (+ (f2cl-lib:fref e-%data% (kp1) ((1 *)) e-%offset%)
  78                      (* t$ (f2cl-lib:fref e-%data% (k) ((1 *)) e-%offset%))))
  79           (setf (f2cl-lib:fref e-%data% (kp1) ((1 *)) e-%offset%) 0.0)
  80           (setf (f2cl-lib:fref b-%data% (kp1) ((1 *)) b-%offset%)
  81                   (+ (f2cl-lib:fref b-%data% (kp1) ((1 *)) b-%offset%)
  82                      (* t$ (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%))))
  83          label30))
  84      label40
  85       (if (/= (f2cl-lib:fref c-%data% (n) ((1 *)) c-%offset%) 0.0)
  86           (go label50))
  87       (setf info n)
  88       (go label90)
  89      label50
  90       (setf nm2 (f2cl-lib:int-sub n 2))
  91       (setf (f2cl-lib:fref b-%data% (n) ((1 *)) b-%offset%)
  92               (/ (f2cl-lib:fref b-%data% (n) ((1 *)) b-%offset%)
  93                  (f2cl-lib:fref c-%data% (n) ((1 *)) c-%offset%)))
  94       (if (= n 1) (go label80))
  95       (setf (f2cl-lib:fref b-%data% (nm1) ((1 *)) b-%offset%)
  96               (/
  97                (- (f2cl-lib:fref b-%data% (nm1) ((1 *)) b-%offset%)
  98                   (* (f2cl-lib:fref d-%data% (nm1) ((1 *)) d-%offset%)
  99                      (f2cl-lib:fref b-%data% (n) ((1 *)) b-%offset%)))
 100                (f2cl-lib:fref c-%data% (nm1) ((1 *)) c-%offset%)))
 101       (if (< nm2 1) (go label70))
 102       (f2cl-lib:fdo (kb 1 (f2cl-lib:int-add kb 1))
 103                     ((> kb nm2) nil)
 104         (tagbody
 105           (setf k (f2cl-lib:int-add (f2cl-lib:int-sub nm2 kb) 1))
 106           (setf (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%)
 107                   (/
 108                    (- (f2cl-lib:fref b-%data% (k) ((1 *)) b-%offset%)
 109                       (* (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%)
 110                          (f2cl-lib:fref b-%data%
 111                                         ((f2cl-lib:int-add k 1))
 112                                         ((1 *))
 113                                         b-%offset%))
 114                       (* (f2cl-lib:fref e-%data% (k) ((1 *)) e-%offset%)
 115                          (f2cl-lib:fref b-%data%
 116                                         ((f2cl-lib:int-add k 2))
 117                                         ((1 *))
 118                                         b-%offset%)))
 119                    (f2cl-lib:fref c-%data% (k) ((1 *)) c-%offset%)))
 120          label60))
 121      label70
 122      label80
 123      label90
 124      label100
 125       (go end_label)
 126      end_label
 127       (return (values nil nil nil nil nil info)))))
 128
 129 (in-package #:cl-user)
 130 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 131 (eval-when (:load-toplevel :compile-toplevel :execute)
 132   (setf (gethash 'fortran-to-lisp::dgtsl fortran-to-lisp::*f2cl-function-info*)
 133           (fortran-to-lisp::make-f2cl-finfo
 134            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 135                         (array double-float (*)) (array double-float (*))
 136                         (array double-float (*)) (fortran-to-lisp::integer4))
 137            :return-values '(nil nil nil nil nil fortran-to-lisp::info)
 138            :calls 'nil)))
 139