src/numerical/slatec/dqmomo.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 dqmomo (alfa beta ri rj rg rh integr)
  21   (declare (type (f2cl-lib:integer4) integr)
  22            (type (array double-float (*)) rh rg rj ri)
  23            (type (double-float) beta alfa))
  24   (f2cl-lib:with-multi-array-data
  25       ((ri double-float ri-%data% ri-%offset%)
  26        (rj double-float rj-%data% rj-%offset%)
  27        (rg double-float rg-%data% rg-%offset%)
  28        (rh double-float rh-%data% rh-%offset%))
  29     (prog ((i 0) (im1 0) (alfp1 0.0) (alfp2 0.0) (an 0.0) (anm1 0.0)
  30            (betp1 0.0) (betp2 0.0) (ralf 0.0) (rbet 0.0))
  31       (declare (type (double-float) rbet ralf betp2 betp1 anm1 an alfp2 alfp1)
  32                (type (f2cl-lib:integer4) im1 i))
  33       (setf alfp1 (+ alfa 1.0))
  34       (setf betp1 (+ beta 1.0))
  35       (setf alfp2 (+ alfa 2.0))
  36       (setf betp2 (+ beta 2.0))
  37       (setf ralf (expt 2.0 alfp1))
  38       (setf rbet (expt 2.0 betp1))
  39       (setf (f2cl-lib:fref ri-%data% (1) ((1 25)) ri-%offset%) (/ ralf alfp1))
  40       (setf (f2cl-lib:fref rj-%data% (1) ((1 25)) rj-%offset%) (/ rbet betp1))
  41       (setf (f2cl-lib:fref ri-%data% (2) ((1 25)) ri-%offset%)
  42               (/ (* (f2cl-lib:fref ri-%data% (1) ((1 25)) ri-%offset%) alfa)
  43                  alfp2))
  44       (setf (f2cl-lib:fref rj-%data% (2) ((1 25)) rj-%offset%)
  45               (/ (* (f2cl-lib:fref rj-%data% (1) ((1 25)) rj-%offset%) beta)
  46                  betp2))
  47       (setf an 2.0)
  48       (setf anm1 1.0)
  49       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
  50                     ((> i 25) nil)
  51         (tagbody
  52           (setf (f2cl-lib:fref ri-%data% (i) ((1 25)) ri-%offset%)
  53                   (/
  54                    (-
  55                     (+ ralf
  56                        (* an
  57                           (- an alfp2)
  58                           (f2cl-lib:fref ri-%data%
  59                                          ((f2cl-lib:int-sub i 1))
  60                                          ((1 25))
  61                                          ri-%offset%))))
  62                    (* anm1 (+ an alfp1))))
  63           (setf (f2cl-lib:fref rj-%data% (i) ((1 25)) rj-%offset%)
  64                   (/
  65                    (-
  66                     (+ rbet
  67                        (* an
  68                           (- an betp2)
  69                           (f2cl-lib:fref rj-%data%
  70                                          ((f2cl-lib:int-sub i 1))
  71                                          ((1 25))
  72                                          rj-%offset%))))
  73                    (* anm1 (+ an betp1))))
  74           (setf anm1 an)
  75           (setf an (+ an 1.0))
  76          label20))
  77       (if (= integr 1) (go label70))
  78       (if (= integr 3) (go label40))
  79       (setf (f2cl-lib:fref rg-%data% (1) ((1 25)) rg-%offset%)
  80               (/ (- (f2cl-lib:fref ri-%data% (1) ((1 25)) ri-%offset%)) alfp1))
  81       (setf (f2cl-lib:fref rg-%data% (2) ((1 25)) rg-%offset%)
  82               (- (/ (- (+ ralf ralf)) (* alfp2 alfp2))
  83                  (f2cl-lib:fref rg-%data% (1) ((1 25)) rg-%offset%)))
  84       (setf an 2.0)
  85       (setf anm1 1.0)
  86       (setf im1 2)
  87       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
  88                     ((> i 25) nil)
  89         (tagbody
  90           (setf (f2cl-lib:fref rg-%data% (i) ((1 25)) rg-%offset%)
  91                   (/
  92                    (-
  93                     (+
  94                      (* an
  95                         (- an alfp2)
  96                         (f2cl-lib:fref rg-%data% (im1) ((1 25)) rg-%offset%))
  97                      (* -1
  98                         an
  99                         (f2cl-lib:fref ri-%data% (im1) ((1 25)) ri-%offset%))
 100                      (* anm1
 101                         (f2cl-lib:fref ri-%data% (i) ((1 25)) ri-%offset%))))
 102                    (* anm1 (+ an alfp1))))
 103           (setf anm1 an)
 104           (setf an (+ an 1.0))
 105           (setf im1 i)
 106          label30))
 107       (if (= integr 2) (go label70))
 108      label40
 109       (setf (f2cl-lib:fref rh-%data% (1) ((1 25)) rh-%offset%)
 110               (/ (- (f2cl-lib:fref rj-%data% (1) ((1 25)) rj-%offset%)) betp1))
 111       (setf (f2cl-lib:fref rh-%data% (2) ((1 25)) rh-%offset%)
 112               (- (/ (- (+ rbet rbet)) (* betp2 betp2))
 113                  (f2cl-lib:fref rh-%data% (1) ((1 25)) rh-%offset%)))
 114       (setf an 2.0)
 115       (setf anm1 1.0)
 116       (setf im1 2)
 117       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
 118                     ((> i 25) nil)
 119         (tagbody
 120           (setf (f2cl-lib:fref rh-%data% (i) ((1 25)) rh-%offset%)
 121                   (/
 122                    (-
 123                     (+
 124                      (* an
 125                         (- an betp2)
 126                         (f2cl-lib:fref rh-%data% (im1) ((1 25)) rh-%offset%))
 127                      (* -1
 128                         an
 129                         (f2cl-lib:fref rj-%data% (im1) ((1 25)) rj-%offset%))
 130                      (* anm1
 131                         (f2cl-lib:fref rj-%data% (i) ((1 25)) rj-%offset%))))
 132                    (* anm1 (+ an betp1))))
 133           (setf anm1 an)
 134           (setf an (+ an 1.0))
 135           (setf im1 i)
 136          label50))
 137       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 2))
 138                     ((> i 25) nil)
 139         (tagbody
 140           (setf (f2cl-lib:fref rh-%data% (i) ((1 25)) rh-%offset%)
 141                   (- (f2cl-lib:fref rh-%data% (i) ((1 25)) rh-%offset%)))
 142          label60))
 143      label70
 144       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 2))
 145                     ((> i 25) nil)
 146         (tagbody
 147           (setf (f2cl-lib:fref rj-%data% (i) ((1 25)) rj-%offset%)
 148                   (- (f2cl-lib:fref rj-%data% (i) ((1 25)) rj-%offset%)))
 149          label80))
 150       (go end_label)
 151      end_label
 152       (return (values nil nil nil nil nil nil nil)))))
 153
 154 (in-package #:cl-user)
 155 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 156 (eval-when (:load-toplevel :compile-toplevel :execute)
 157   (setf (gethash 'fortran-to-lisp::dqmomo
 158                  fortran-to-lisp::*f2cl-function-info*)
 159           (fortran-to-lisp::make-f2cl-finfo
 160            :arg-types '((double-float) (double-float) (array double-float (*))
 161                         (array double-float (*)) (array double-float (*))
 162                         (array double-float (*)) (fortran-to-lisp::integer4))
 163            :return-values '(nil nil nil nil nil nil nil)
 164            :calls 'nil)))
 165