src/numerical/slatec/zuoik.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 ':simple-array)
  14 ;;;           (:array-slicing nil) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :slatec)
  18
  19
  20 (let ((zeror 0.0) (zeroi 0.0) (aic 1.2655121234846454))
  21   (declare (type (double-float) zeror zeroi aic))
  22   (defun zuoik (zr zi fnu kode ikflg n yr yi nuf tol elim alim)
  23     (declare (type (simple-array double-float (*)) yi yr)
  24              (type (f2cl-lib:integer4) nuf n ikflg kode)
  25              (type (double-float) alim elim tol fnu zi zr))
  26     (prog ((cwrkr (make-array 16 :element-type 'double-float))
  27            (cwrki (make-array 16 :element-type 'double-float)) (i 0) (idum 0)
  28            (iform 0) (init 0) (nn 0) (nw 0) (aarg 0.0) (aphi 0.0) (argi 0.0)
  29            (argr 0.0) (asumi 0.0) (asumr 0.0) (ascle 0.0) (ax 0.0) (ay 0.0)
  30            (bsumi 0.0) (bsumr 0.0) (czi 0.0) (czr 0.0) (fnn 0.0) (gnn 0.0)
  31            (gnu 0.0) (phii 0.0) (phir 0.0) (rcz 0.0) (str 0.0) (sti 0.0)
  32            (sumi 0.0) (sumr 0.0) (zbi 0.0) (zbr 0.0) (zeta1i 0.0) (zeta1r 0.0)
  33            (zeta2i 0.0) (zeta2r 0.0) (zni 0.0) (znr 0.0) (zri 0.0) (zrr 0.0))
  34       (declare (type (simple-array double-float (16)) cwrkr cwrki)
  35                (type (double-float) zrr zri znr zni zeta2r zeta2i zeta1r zeta1i
  36                                     zbr zbi sumr sumi sti str rcz phir phii gnu
  37                                     gnn fnn czr czi bsumr bsumi ay ax ascle
  38                                     asumr asumi argr argi aphi aarg)
  39                (type (f2cl-lib:integer4) nw nn init iform idum i))
  40       (setf nuf 0)
  41       (setf nn n)
  42       (setf zrr zr)
  43       (setf zri zi)
  44       (if (>= zr 0.0) (go label10))
  45       (setf zrr (- zr))
  46       (setf zri (- zi))
  47      label10
  48       (setf zbr zrr)
  49       (setf zbi zri)
  50       (setf ax (* (abs zr) 1.7321))
  51       (setf ay (abs zi))
  52       (setf iform 1)
  53       (if (> ay ax) (setf iform 2))
  54       (setf gnu (max fnu 1.0))
  55       (if (= ikflg 1) (go label20))
  56       (setf fnn (coerce (the f2cl-lib:integer4 nn) 'double-float))
  57       (setf gnn (- (+ fnu fnn) 1.0))
  58       (setf gnu (max gnn fnn))
  59      label20
  60       (if (= iform 2) (go label30))
  61       (setf init 0)
  62       (multiple-value-bind
  63             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  64              var-11 var-12 var-13 var-14 var-15 var-16)
  65           (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
  66            zeta2i sumr sumi cwrkr cwrki)
  67         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  68         (setf init var-6)
  69         (setf phir var-7)
  70         (setf phii var-8)
  71         (setf zeta1r var-9)
  72         (setf zeta1i var-10)
  73         (setf zeta2r var-11)
  74         (setf zeta2i var-12)
  75         (setf sumr var-13)
  76         (setf sumi var-14))
  77       (setf czr (- zeta2r zeta1r))
  78       (setf czi (- zeta2i zeta1i))
  79       (go label50)
  80      label30
  81       (setf znr zri)
  82       (setf zni (- zrr))
  83       (if (> zi 0.0) (go label40))
  84       (setf znr (- znr))
  85      label40
  86       (multiple-value-bind
  87             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  88              var-11 var-12 var-13 var-14 var-15 var-16)
  89           (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
  90            zeta2i asumr asumi bsumr bsumi)
  91         (declare (ignore var-0 var-1 var-2 var-3 var-4))
  92         (setf phir var-5)
  93         (setf phii var-6)
  94         (setf argr var-7)
  95         (setf argi var-8)
  96         (setf zeta1r var-9)
  97         (setf zeta1i var-10)
  98         (setf zeta2r var-11)
  99         (setf zeta2i var-12)
 100         (setf asumr var-13)
 101         (setf asumi var-14)
 102         (setf bsumr var-15)
 103         (setf bsumi var-16))
 104       (setf czr (- zeta2r zeta1r))
 105       (setf czi (- zeta2i zeta1i))
 106       (setf aarg (coerce (realpart (zabs argr argi)) 'double-float))
 107      label50
 108       (if (= kode 1) (go label60))
 109       (setf czr (- czr zbr))
 110       (setf czi (- czi zbi))
 111      label60
 112       (if (= ikflg 1) (go label70))
 113       (setf czr (- czr))
 114       (setf czi (- czi))
 115      label70
 116       (setf aphi (coerce (realpart (zabs phir phii)) 'double-float))
 117       (setf rcz czr)
 118       (if (> rcz elim) (go label210))
 119       (if (< rcz alim) (go label80))
 120       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
 121       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
 122       (if (> rcz elim) (go label210))
 123       (go label130)
 124      label80
 125       (if (< rcz (- elim)) (go label90))
 126       (if (> rcz (- alim)) (go label130))
 127       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
 128       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
 129       (if (> rcz (- elim)) (go label110))
 130      label90
 131       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 132                     ((> i nn) nil)
 133         (tagbody
 134           (setf (f2cl-lib:fref yr (i) ((1 n))) zeror)
 135           (setf (f2cl-lib:fref yi (i) ((1 n))) zeroi)
 136          label100))
 137       (setf nuf nn)
 138       (go end_label)
 139      label110
 140       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
 141       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 142           (zlog phir phii str sti idum)
 143         (declare (ignore var-0 var-1))
 144         (setf str var-2)
 145         (setf sti var-3)
 146         (setf idum var-4))
 147       (setf czr (+ czr str))
 148       (setf czi (+ czi sti))
 149       (if (= iform 1) (go label120))
 150       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 151           (zlog argr argi str sti idum)
 152         (declare (ignore var-0 var-1))
 153         (setf str var-2)
 154         (setf sti var-3)
 155         (setf idum var-4))
 156       (setf czr (- czr (* 0.25 str) aic))
 157       (setf czi (- czi (* 0.25 sti)))
 158      label120
 159       (setf ax (/ (exp rcz) tol))
 160       (setf ay czi)
 161       (setf czr (* ax (cos ay)))
 162       (setf czi (* ax (sin ay)))
 163       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 164           (zuchk czr czi nw ascle tol)
 165         (declare (ignore var-0 var-1 var-3 var-4))
 166         (setf nw var-2))
 167       (if (/= nw 0) (go label90))
 168      label130
 169       (if (= ikflg 2) (go end_label))
 170       (if (= n 1) (go end_label))
 171      label140
 172       (setf gnu (+ fnu (f2cl-lib:int-sub nn 1)))
 173       (if (= iform 2) (go label150))
 174       (setf init 0)
 175       (multiple-value-bind
 176             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 177              var-11 var-12 var-13 var-14 var-15 var-16)
 178           (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
 179            zeta2i sumr sumi cwrkr cwrki)
 180         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
 181         (setf init var-6)
 182         (setf phir var-7)
 183         (setf phii var-8)
 184         (setf zeta1r var-9)
 185         (setf zeta1i var-10)
 186         (setf zeta2r var-11)
 187         (setf zeta2i var-12)
 188         (setf sumr var-13)
 189         (setf sumi var-14))
 190       (setf czr (- zeta2r zeta1r))
 191       (setf czi (- zeta2i zeta1i))
 192       (go label160)
 193      label150
 194       (multiple-value-bind
 195             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 196              var-11 var-12 var-13 var-14 var-15 var-16)
 197           (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
 198            zeta2i asumr asumi bsumr bsumi)
 199         (declare (ignore var-0 var-1 var-2 var-3 var-4))
 200         (setf phir var-5)
 201         (setf phii var-6)
 202         (setf argr var-7)
 203         (setf argi var-8)
 204         (setf zeta1r var-9)
 205         (setf zeta1i var-10)
 206         (setf zeta2r var-11)
 207         (setf zeta2i var-12)
 208         (setf asumr var-13)
 209         (setf asumi var-14)
 210         (setf bsumr var-15)
 211         (setf bsumi var-16))
 212       (setf czr (- zeta2r zeta1r))
 213       (setf czi (- zeta2i zeta1i))
 214       (setf aarg (coerce (realpart (zabs argr argi)) 'double-float))
 215      label160
 216       (if (= kode 1) (go label170))
 217       (setf czr (- czr zbr))
 218       (setf czi (- czi zbi))
 219      label170
 220       (setf aphi (coerce (realpart (zabs phir phii)) 'double-float))
 221       (setf rcz czr)
 222       (if (< rcz (- elim)) (go label180))
 223       (if (> rcz (- alim)) (go end_label))
 224       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
 225       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
 226       (if (> rcz (- elim)) (go label190))
 227      label180
 228       (setf (f2cl-lib:fref yr (nn) ((1 n))) zeror)
 229       (setf (f2cl-lib:fref yi (nn) ((1 n))) zeroi)
 230       (setf nn (f2cl-lib:int-sub nn 1))
 231       (setf nuf (f2cl-lib:int-add nuf 1))
 232       (if (= nn 0) (go end_label))
 233       (go label140)
 234      label190
 235       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
 236       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 237           (zlog phir phii str sti idum)
 238         (declare (ignore var-0 var-1))
 239         (setf str var-2)
 240         (setf sti var-3)
 241         (setf idum var-4))
 242       (setf czr (+ czr str))
 243       (setf czi (+ czi sti))
 244       (if (= iform 1) (go label200))
 245       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 246           (zlog argr argi str sti idum)
 247         (declare (ignore var-0 var-1))
 248         (setf str var-2)
 249         (setf sti var-3)
 250         (setf idum var-4))
 251       (setf czr (- czr (* 0.25 str) aic))
 252       (setf czi (- czi (* 0.25 sti)))
 253      label200
 254       (setf ax (/ (exp rcz) tol))
 255       (setf ay czi)
 256       (setf czr (* ax (cos ay)))
 257       (setf czi (* ax (sin ay)))
 258       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 259           (zuchk czr czi nw ascle tol)
 260         (declare (ignore var-0 var-1 var-3 var-4))
 261         (setf nw var-2))
 262       (if (/= nw 0) (go label180))
 263       (go end_label)
 264      label210
 265       (setf nuf -1)
 266       (go end_label)
 267      end_label
 268       (return (values nil nil nil nil nil nil nil nil nuf nil nil nil)))))
 269
 270 (in-package #:cl-user)
 271 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 272 (eval-when (:load-toplevel :compile-toplevel :execute)
 273   (setf (gethash 'fortran-to-lisp::zuoik fortran-to-lisp::*f2cl-function-info*)
 274           (fortran-to-lisp::make-f2cl-finfo
 275            :arg-types '((double-float) (double-float) (double-float)
 276                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 277                         (fortran-to-lisp::integer4)
 278                         (simple-array double-float (*))
 279                         (simple-array double-float (*))
 280                         (fortran-to-lisp::integer4) (double-float)
 281                         (double-float) (double-float))
 282            :return-values '(nil nil nil nil nil nil nil nil
 283                             fortran-to-lisp::nuf nil nil nil)
 284            :calls '(fortran-to-lisp::zuchk fortran-to-lisp::zlog
 285                     fortran-to-lisp::d1mach fortran-to-lisp::zabs
 286                     fortran-to-lisp::zunhj fortran-to-lisp::zunik))))
 287