src/numerical/slatec/dqpsrt.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 dqpsrt (limit last$ maxerr ermax elist iord nrmax)
  21   (declare (type (array f2cl-lib:integer4 (*)) iord)
  22            (type (array double-float (*)) elist)
  23            (type (double-float) ermax)
  24            (type (f2cl-lib:integer4) nrmax maxerr last$ limit))
  25   (f2cl-lib:with-multi-array-data
  26       ((elist double-float elist-%data% elist-%offset%)
  27        (iord f2cl-lib:integer4 iord-%data% iord-%offset%))
  28     (prog ((i 0) (ibeg 0) (ido 0) (isucc 0) (j 0) (jbnd 0) (jupbn 0) (k 0)
  29            (errmax 0.0) (errmin 0.0))
  30       (declare (type (double-float) errmin errmax)
  31                (type (f2cl-lib:integer4) k jupbn jbnd j isucc ido ibeg i))
  32       (if (> last$ 2) (go label10))
  33       (setf (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 1)
  34       (setf (f2cl-lib:fref iord-%data% (2) ((1 *)) iord-%offset%) 2)
  35       (go label90)
  36      label10
  37       (setf errmax
  38               (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%))
  39       (if (= nrmax 1) (go label30))
  40       (setf ido (f2cl-lib:int-sub nrmax 1))
  41       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  42                     ((> i ido) nil)
  43         (tagbody
  44           (setf isucc
  45                   (f2cl-lib:fref iord-%data%
  46                                  ((f2cl-lib:int-sub nrmax 1))
  47                                  ((1 *))
  48                                  iord-%offset%))
  49           (if
  50            (<= errmax
  51                (f2cl-lib:fref elist-%data% (isucc) ((1 *)) elist-%offset%))
  52            (go label30))
  53           (setf (f2cl-lib:fref iord-%data% (nrmax) ((1 *)) iord-%offset%)
  54                   isucc)
  55           (setf nrmax (f2cl-lib:int-sub nrmax 1))
  56          label20))
  57      label30
  58       (setf jupbn last$)
  59       (if (> last$ (+ (the f2cl-lib:integer4 (truncate limit 2)) 2))
  60           (setf jupbn (f2cl-lib:int-sub (f2cl-lib:int-add limit 3) last$)))
  61       (setf errmin (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%))
  62       (setf jbnd (f2cl-lib:int-sub jupbn 1))
  63       (setf ibeg (f2cl-lib:int-add nrmax 1))
  64       (if (> ibeg jbnd) (go label50))
  65       (f2cl-lib:fdo (i ibeg (f2cl-lib:int-add i 1))
  66                     ((> i jbnd) nil)
  67         (tagbody
  68           (setf isucc (f2cl-lib:fref iord-%data% (i) ((1 *)) iord-%offset%))
  69           (if
  70            (>= errmax
  71                (f2cl-lib:fref elist-%data% (isucc) ((1 *)) elist-%offset%))
  72            (go label60))
  73           (setf (f2cl-lib:fref iord-%data%
  74                                ((f2cl-lib:int-sub i 1))
  75                                ((1 *))
  76                                iord-%offset%)
  77                   isucc)
  78          label40))
  79      label50
  80       (setf (f2cl-lib:fref iord-%data% (jbnd) ((1 *)) iord-%offset%) maxerr)
  81       (setf (f2cl-lib:fref iord-%data% (jupbn) ((1 *)) iord-%offset%) last$)
  82       (go label90)
  83      label60
  84       (setf (f2cl-lib:fref iord-%data%
  85                            ((f2cl-lib:int-sub i 1))
  86                            ((1 *))
  87                            iord-%offset%)
  88               maxerr)
  89       (setf k jbnd)
  90       (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1))
  91                     ((> j jbnd) nil)
  92         (tagbody
  93           (setf isucc (f2cl-lib:fref iord-%data% (k) ((1 *)) iord-%offset%))
  94           (if
  95            (< errmin
  96               (f2cl-lib:fref elist-%data% (isucc) ((1 *)) elist-%offset%))
  97            (go label80))
  98           (setf (f2cl-lib:fref iord-%data%
  99                                ((f2cl-lib:int-add k 1))
 100                                ((1 *))
 101                                iord-%offset%)
 102                   isucc)
 103           (setf k (f2cl-lib:int-sub k 1))
 104          label70))
 105       (setf (f2cl-lib:fref iord-%data% (i) ((1 *)) iord-%offset%) last$)
 106       (go label90)
 107      label80
 108       (setf (f2cl-lib:fref iord-%data%
 109                            ((f2cl-lib:int-add k 1))
 110                            ((1 *))
 111                            iord-%offset%)
 112               last$)
 113      label90
 114       (setf maxerr (f2cl-lib:fref iord-%data% (nrmax) ((1 *)) iord-%offset%))
 115       (setf ermax (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%))
 116       (go end_label)
 117      end_label
 118       (return (values nil nil maxerr ermax nil nil nrmax)))))
 119
 120 (in-package #:cl-user)
 121 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 122 (eval-when (:load-toplevel :compile-toplevel :execute)
 123   (setf (gethash 'fortran-to-lisp::dqpsrt
 124                  fortran-to-lisp::*f2cl-function-info*)
 125           (fortran-to-lisp::make-f2cl-finfo
 126            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 127                         (fortran-to-lisp::integer4) (double-float)
 128                         (array double-float (*))
 129                         (array fortran-to-lisp::integer4 (*))
 130                         (fortran-to-lisp::integer4))
 131            :return-values '(nil nil fortran-to-lisp::maxerr
 132                             fortran-to-lisp::ermax nil nil
 133                             fortran-to-lisp::nrmax)
 134            :calls 'nil)))
 135