src/numerical/slatec/zacon.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 ((pi$ 3.141592653589793) (zeror 0.0) (coner 1.0))
  21   (declare (type (double-float) pi$ zeror coner))
  22   (defun zacon (zr zi fnu kode mr n yr yi nz rl fnul tol elim alim)
  23     (declare (type (simple-array double-float (*)) yi yr)
  24              (type (f2cl-lib:integer4) nz n mr kode)
  25              (type (double-float) alim elim tol fnul rl fnu zi zr))
  26     (prog ((cyr (make-array 2 :element-type 'double-float))
  27            (cyi (make-array 2 :element-type 'double-float))
  28            (cssr (make-array 3 :element-type 'double-float))
  29            (csrr (make-array 3 :element-type 'double-float))
  30            (bry (make-array 3 :element-type 'double-float)) (i 0) (inu 0)
  31            (iuf 0) (kflag 0) (nn 0) (nw 0) (arg 0.0) (ascle 0.0) (as2 0.0)
  32            (azn 0.0) (bscle 0.0) (cki 0.0) (ckr 0.0) (cpn 0.0) (cscl 0.0)
  33            (cscr 0.0) (csgni 0.0) (csgnr 0.0) (cspni 0.0) (cspnr 0.0) (csr 0.0)
  34            (c1i 0.0) (c1m 0.0) (c1r 0.0) (c2i 0.0) (c2r 0.0) (fmr 0.0) (fn 0.0)
  35            (pti 0.0) (ptr 0.0) (razn 0.0) (rzi 0.0) (rzr 0.0) (sc1i 0.0)
  36            (sc1r 0.0) (sc2i 0.0) (sc2r 0.0) (sgn 0.0) (spn 0.0) (sti 0.0)
  37            (str 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0) (yy 0.0) (zni 0.0)
  38            (znr 0.0))
  39       (declare (type (simple-array double-float (2)) cyr cyi)
  40                (type (simple-array double-float (3)) cssr csrr bry)
  41                (type (double-float) znr zni yy s2r s2i s1r s1i str sti spn sgn
  42                                     sc2r sc2i sc1r sc1i rzr rzi razn ptr pti fn
  43                                     fmr c2r c2i c1r c1m c1i csr cspnr cspni
  44                                     csgnr csgni cscr cscl cpn ckr cki bscle azn
  45                                     as2 ascle arg)
  46                (type (f2cl-lib:integer4) nw nn kflag iuf inu i))
  47       (setf nz 0)
  48       (setf znr (- zr))
  49       (setf zni (- zi))
  50       (setf nn n)
  51       (multiple-value-bind
  52             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  53              var-11 var-12)
  54           (zbinu znr zni fnu kode nn yr yi nw rl fnul tol elim alim)
  55         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  56                          var-10 var-11 var-12))
  57         (setf nw var-7))
  58       (if (< nw 0) (go label90))
  59       (setf nn (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 n)))
  60       (multiple-value-bind
  61             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  62              var-10)
  63           (zbknu znr zni fnu kode nn cyr cyi nw tol elim alim)
  64         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  65                          var-10))
  66         (setf nw var-7))
  67       (if (/= nw 0) (go label90))
  68       (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
  69       (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
  70       (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
  71       (setf sgn (coerce (- (f2cl-lib:dsign pi$ fmr)) 'double-float))
  72       (setf csgnr zeror)
  73       (setf csgni sgn)
  74       (if (= kode 1) (go label10))
  75       (setf yy (- zni))
  76       (setf cpn (cos yy))
  77       (setf spn (sin yy))
  78       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
  79           (zmlt csgnr csgni cpn spn csgnr csgni)
  80         (declare (ignore var-0 var-1 var-2 var-3))
  81         (setf csgnr var-4)
  82         (setf csgni var-5))
  83      label10
  84       (setf inu (f2cl-lib:int fnu))
  85       (setf arg (* (- fnu inu) sgn))
  86       (setf cpn (cos arg))
  87       (setf spn (sin arg))
  88       (setf cspnr cpn)
  89       (setf cspni spn)
  90       (if (= (mod inu 2) 0) (go label20))
  91       (setf cspnr (- cspnr))
  92       (setf cspni (- cspni))
  93      label20
  94       (setf iuf 0)
  95       (setf c1r s1r)
  96       (setf c1i s1i)
  97       (setf c2r (f2cl-lib:fref yr (1) ((1 n))))
  98       (setf c2i (f2cl-lib:fref yi (1) ((1 n))))
  99       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
 100       (if (= kode 1) (go label30))
 101       (multiple-value-bind
 102             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 103           (zs1s2 znr zni c1r c1i c2r c2i nw ascle alim iuf)
 104         (declare (ignore var-0 var-1 var-7 var-8))
 105         (setf c1r var-2)
 106         (setf c1i var-3)
 107         (setf c2r var-4)
 108         (setf c2i var-5)
 109         (setf nw var-6)
 110         (setf iuf var-9))
 111       (setf nz (f2cl-lib:int-add nz nw))
 112       (setf sc1r c1r)
 113       (setf sc1i c1i)
 114      label30
 115       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 116           (zmlt cspnr cspni c1r c1i str sti)
 117         (declare (ignore var-0 var-1 var-2 var-3))
 118         (setf str var-4)
 119         (setf sti var-5))
 120       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 121           (zmlt csgnr csgni c2r c2i ptr pti)
 122         (declare (ignore var-0 var-1 var-2 var-3))
 123         (setf ptr var-4)
 124         (setf pti var-5))
 125       (setf (f2cl-lib:fref yr (1) ((1 n))) (+ str ptr))
 126       (setf (f2cl-lib:fref yi (1) ((1 n))) (+ sti pti))
 127       (if (= n 1) (go end_label))
 128       (setf cspnr (- cspnr))
 129       (setf cspni (- cspni))
 130       (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
 131       (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
 132       (setf c1r s2r)
 133       (setf c1i s2i)
 134       (setf c2r (f2cl-lib:fref yr (2) ((1 n))))
 135       (setf c2i (f2cl-lib:fref yi (2) ((1 n))))
 136       (if (= kode 1) (go label40))
 137       (multiple-value-bind
 138             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 139           (zs1s2 znr zni c1r c1i c2r c2i nw ascle alim iuf)
 140         (declare (ignore var-0 var-1 var-7 var-8))
 141         (setf c1r var-2)
 142         (setf c1i var-3)
 143         (setf c2r var-4)
 144         (setf c2i var-5)
 145         (setf nw var-6)
 146         (setf iuf var-9))
 147       (setf nz (f2cl-lib:int-add nz nw))
 148       (setf sc2r c1r)
 149       (setf sc2i c1i)
 150      label40
 151       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 152           (zmlt cspnr cspni c1r c1i str sti)
 153         (declare (ignore var-0 var-1 var-2 var-3))
 154         (setf str var-4)
 155         (setf sti var-5))
 156       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
 157           (zmlt csgnr csgni c2r c2i ptr pti)
 158         (declare (ignore var-0 var-1 var-2 var-3))
 159         (setf ptr var-4)
 160         (setf pti var-5))
 161       (setf (f2cl-lib:fref yr (2) ((1 n))) (+ str ptr))
 162       (setf (f2cl-lib:fref yi (2) ((1 n))) (+ sti pti))
 163       (if (= n 2) (go end_label))
 164       (setf cspnr (- cspnr))
 165       (setf cspni (- cspni))
 166       (setf azn (coerce (realpart (zabs znr zni)) 'double-float))
 167       (setf razn (/ 1.0 azn))
 168       (setf str (* znr razn))
 169       (setf sti (* (- zni) razn))
 170       (setf rzr (* (+ str str) razn))
 171       (setf rzi (* (+ sti sti) razn))
 172       (setf fn (+ fnu 1.0))
 173       (setf ckr (* fn rzr))
 174       (setf cki (* fn rzi))
 175       (setf cscl (/ 1.0 tol))
 176       (setf cscr tol)
 177       (setf (f2cl-lib:fref cssr (1) ((1 3))) cscl)
 178       (setf (f2cl-lib:fref cssr (2) ((1 3))) coner)
 179       (setf (f2cl-lib:fref cssr (3) ((1 3))) cscr)
 180       (setf (f2cl-lib:fref csrr (1) ((1 3))) cscr)
 181       (setf (f2cl-lib:fref csrr (2) ((1 3))) coner)
 182       (setf (f2cl-lib:fref csrr (3) ((1 3))) cscl)
 183       (setf (f2cl-lib:fref bry (1) ((1 3))) ascle)
 184       (setf (f2cl-lib:fref bry (2) ((1 3))) (/ 1.0 ascle))
 185       (setf (f2cl-lib:fref bry (3) ((1 3))) (f2cl-lib:d1mach 2))
 186       (setf as2 (coerce (realpart (zabs s2r s2i)) 'double-float))
 187       (setf kflag 2)
 188       (if (> as2 (f2cl-lib:fref bry (1) ((1 3)))) (go label50))
 189       (setf kflag 1)
 190       (go label60)
 191      label50
 192       (if (< as2 (f2cl-lib:fref bry (2) ((1 3)))) (go label60))
 193       (setf kflag 3)
 194      label60
 195       (setf bscle (f2cl-lib:fref bry (kflag) ((1 3))))
 196       (setf s1r (* s1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 197       (setf s1i (* s1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 198       (setf s2r (* s2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 199       (setf s2i (* s2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 200       (setf csr (f2cl-lib:fref csrr (kflag) ((1 3))))
 201       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
 202                     ((> i n) nil)
 203         (tagbody
 204           (setf str s2r)
 205           (setf sti s2i)
 206           (setf s2r (+ (- (* ckr str) (* cki sti)) s1r))
 207           (setf s2i (+ (* ckr sti) (* cki str) s1i))
 208           (setf s1r str)
 209           (setf s1i sti)
 210           (setf c1r (* s2r csr))
 211           (setf c1i (* s2i csr))
 212           (setf str c1r)
 213           (setf sti c1i)
 214           (setf c2r (f2cl-lib:fref yr (i) ((1 n))))
 215           (setf c2i (f2cl-lib:fref yi (i) ((1 n))))
 216           (if (= kode 1) (go label70))
 217           (if (< iuf 0) (go label70))
 218           (multiple-value-bind
 219                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 220               (zs1s2 znr zni c1r c1i c2r c2i nw ascle alim iuf)
 221             (declare (ignore var-0 var-1 var-7 var-8))
 222             (setf c1r var-2)
 223             (setf c1i var-3)
 224             (setf c2r var-4)
 225             (setf c2i var-5)
 226             (setf nw var-6)
 227             (setf iuf var-9))
 228           (setf nz (f2cl-lib:int-add nz nw))
 229           (setf sc1r sc2r)
 230           (setf sc1i sc2i)
 231           (setf sc2r c1r)
 232           (setf sc2i c1i)
 233           (if (/= iuf 3) (go label70))
 234           (setf iuf -4)
 235           (setf s1r (* sc1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 236           (setf s1i (* sc1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 237           (setf s2r (* sc2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 238           (setf s2i (* sc2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 239           (setf str sc2r)
 240           (setf sti sc2i)
 241          label70
 242           (setf ptr (- (* cspnr c1r) (* cspni c1i)))
 243           (setf pti (+ (* cspnr c1i) (* cspni c1r)))
 244           (setf (f2cl-lib:fref yr (i) ((1 n)))
 245                   (- (+ ptr (* csgnr c2r)) (* csgni c2i)))
 246           (setf (f2cl-lib:fref yi (i) ((1 n)))
 247                   (+ pti (* csgnr c2i) (* csgni c2r)))
 248           (setf ckr (+ ckr rzr))
 249           (setf cki (+ cki rzi))
 250           (setf cspnr (- cspnr))
 251           (setf cspni (- cspni))
 252           (if (>= kflag 3) (go label80))
 253           (setf ptr (abs c1r))
 254           (setf pti (abs c1i))
 255           (setf c1m (max ptr pti))
 256           (if (<= c1m bscle) (go label80))
 257           (setf kflag (f2cl-lib:int-add kflag 1))
 258           (setf bscle (f2cl-lib:fref bry (kflag) ((1 3))))
 259           (setf s1r (* s1r csr))
 260           (setf s1i (* s1i csr))
 261           (setf s2r str)
 262           (setf s2i sti)
 263           (setf s1r (* s1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 264           (setf s1i (* s1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 265           (setf s2r (* s2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 266           (setf s2i (* s2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 267           (setf csr (f2cl-lib:fref csrr (kflag) ((1 3))))
 268          label80))
 269       (go end_label)
 270      label90
 271       (setf nz -1)
 272       (if (= nw -2) (setf nz -2))
 273       (go end_label)
 274      end_label
 275       (return
 276        (values nil nil nil nil nil nil nil nil nz nil nil nil nil nil)))))
 277
 278 (in-package #:cl-user)
 279 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 280 (eval-when (:load-toplevel :compile-toplevel :execute)
 281   (setf (gethash 'fortran-to-lisp::zacon fortran-to-lisp::*f2cl-function-info*)
 282           (fortran-to-lisp::make-f2cl-finfo
 283            :arg-types '((double-float) (double-float) (double-float)
 284                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 285                         (fortran-to-lisp::integer4)
 286                         (simple-array double-float (*))
 287                         (simple-array double-float (*))
 288                         (fortran-to-lisp::integer4) (double-float)
 289                         (double-float) (double-float) (double-float)
 290                         (double-float))
 291            :return-values '(nil nil nil nil nil nil nil nil fortran-to-lisp::nz
 292                             nil nil nil nil nil)
 293            :calls '(fortran-to-lisp::zabs fortran-to-lisp::zs1s2
 294                     fortran-to-lisp::d1mach fortran-to-lisp::zmlt
 295                     fortran-to-lisp::zbknu fortran-to-lisp::zbinu))))
 296