src/numerical/slatec/zunk2.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)
  21       (zeroi 0.0)
  22       (coner 1.0)
  23       (cr1r 1.0)
  24       (cr1i 1.7320508075688772)
  25       (cr2r -0.5)
  26       (cr2i -0.8660254037844386)
  27       (hpi 1.5707963267948966)
  28       (pi$ 3.141592653589793)
  29       (aic 1.2655121234846454)
  30       (cipr
  31        (make-array 4
  32                    :element-type 'double-float
  33                    :initial-contents '(1.0 0.0 -1.0 0.0)))
  34       (cipi
  35        (make-array 4
  36                    :element-type 'double-float
  37                    :initial-contents '(0.0 -1.0 0.0 1.0))))
  38   (declare (type (double-float) zeror zeroi coner cr1r cr1i cr2r cr2i hpi pi$
  39                                 aic)
  40            (type (simple-array double-float (4)) cipr cipi))
  41   (defun zunk2 (zr zi fnu kode mr n yr yi nz tol elim alim)
  42     (declare (type (simple-array double-float (*)) yi yr)
  43              (type (f2cl-lib:integer4) nz n mr kode)
  44              (type (double-float) alim elim tol fnu zi zr))
  45     (prog ((bry (make-array 3 :element-type 'double-float))
  46            (asumr (make-array 2 :element-type 'double-float))
  47            (asumi (make-array 2 :element-type 'double-float))
  48            (bsumr (make-array 2 :element-type 'double-float))
  49            (bsumi (make-array 2 :element-type 'double-float))
  50            (phir (make-array 2 :element-type 'double-float))
  51            (phii (make-array 2 :element-type 'double-float))
  52            (argr (make-array 2 :element-type 'double-float))
  53            (argi (make-array 2 :element-type 'double-float))
  54            (zeta1r (make-array 2 :element-type 'double-float))
  55            (zeta1i (make-array 2 :element-type 'double-float))
  56            (zeta2r (make-array 2 :element-type 'double-float))
  57            (zeta2i (make-array 2 :element-type 'double-float))
  58            (cyr (make-array 2 :element-type 'double-float))
  59            (cyi (make-array 2 :element-type 'double-float))
  60            (cssr (make-array 3 :element-type 'double-float))
  61            (csrr (make-array 3 :element-type 'double-float)) (i 0) (ib 0)
  62            (iflag 0) (ifn 0) (il 0) (in 0) (inu 0) (iuf 0) (k 0) (kdflg 0)
  63            (kflag 0) (kk 0) (nai 0) (ndai 0) (nw 0) (idum 0) (j 0) (ipard 0)
  64            (ic 0) (aarg 0.0) (aii 0.0) (air 0.0) (ang 0.0) (aphi 0.0)
  65            (argdi 0.0) (argdr 0.0) (asc 0.0) (ascle 0.0) (asumdi 0.0)
  66            (asumdr 0.0) (bsumdi 0.0) (bsumdr 0.0) (car$ 0.0) (cki 0.0)
  67            (ckr 0.0) (crsc 0.0) (cscl 0.0) (csgni 0.0) (csi 0.0) (cspni 0.0)
  68            (cspnr 0.0) (csr 0.0) (c1i 0.0) (c1r 0.0) (c2i 0.0) (c2m 0.0)
  69            (c2r 0.0) (daii 0.0) (dair 0.0) (fmr 0.0) (fn 0.0) (fnf 0.0)
  70            (phidi 0.0) (phidr 0.0) (pti 0.0) (ptr 0.0) (rast 0.0) (razr 0.0)
  71            (rs1 0.0) (rzi 0.0) (rzr 0.0) (sar 0.0) (sgn 0.0) (sti 0.0)
  72            (str 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0) (yy 0.0) (zbi 0.0)
  73            (zbr 0.0) (zet1di 0.0) (zet1dr 0.0) (zet2di 0.0) (zet2dr 0.0)
  74            (zni 0.0) (znr 0.0) (zri 0.0) (zrr 0.0))
  75       (declare (type (simple-array double-float (3)) cssr csrr bry)
  76                (type (simple-array double-float (2)) zeta2r zeta2i zeta1r
  77                                                      zeta1i phir phii cyr cyi
  78                                                      bsumr bsumi asumr asumi
  79                                                      argr argi)
  80                (type (double-float) zrr zri znr zni zet2dr zet2di zet1dr zet1di
  81                                     zbr zbi yy s2r s2i s1r s1i str sti sgn sar
  82                                     rzr rzi rs1 razr rast ptr pti phidr phidi
  83                                     fnf fn fmr dair daii c2r c2m c2i c1r c1i
  84                                     csr cspnr cspni csi csgni cscl crsc ckr cki
  85                                     car$ bsumdr bsumdi asumdr asumdi ascle asc
  86                                     argdr argdi aphi ang air aii aarg)
  87                (type (f2cl-lib:integer4) ic ipard j idum nw ndai nai kk kflag
  88                                          kdflg k iuf inu in il ifn iflag ib i))
  89       (setf kdflg 1)
  90       (setf nz 0)
  91       (setf cscl (/ 1.0 tol))
  92       (setf crsc tol)
  93       (setf (f2cl-lib:fref cssr (1) ((1 3))) cscl)
  94       (setf (f2cl-lib:fref cssr (2) ((1 3))) coner)
  95       (setf (f2cl-lib:fref cssr (3) ((1 3))) crsc)
  96       (setf (f2cl-lib:fref csrr (1) ((1 3))) crsc)
  97       (setf (f2cl-lib:fref csrr (2) ((1 3))) coner)
  98       (setf (f2cl-lib:fref csrr (3) ((1 3))) cscl)
  99       (setf (f2cl-lib:fref bry (1) ((1 3)))
 100               (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
 101       (setf (f2cl-lib:fref bry (2) ((1 3)))
 102               (/ 1.0 (f2cl-lib:fref bry (1) ((1 3)))))
 103       (setf (f2cl-lib:fref bry (3) ((1 3))) (f2cl-lib:d1mach 2))
 104       (setf zrr zr)
 105       (setf zri zi)
 106       (if (>= zr 0.0) (go label10))
 107       (setf zrr (- zr))
 108       (setf zri (- zi))
 109      label10
 110       (setf yy zri)
 111       (setf znr zri)
 112       (setf zni (- zrr))
 113       (setf zbr zrr)
 114       (setf zbi zri)
 115       (setf inu (f2cl-lib:int fnu))
 116       (setf fnf (- fnu inu))
 117       (setf ang (* (- hpi) fnf))
 118       (setf car$ (cos ang))
 119       (setf sar (sin ang))
 120       (setf c2r (* hpi sar))
 121       (setf c2i (* (- hpi) car$))
 122       (setf kk (f2cl-lib:int-add (mod inu 4) 1))
 123       (setf str
 124               (- (* c2r (f2cl-lib:fref cipr (kk) ((1 4))))
 125                  (* c2i (f2cl-lib:fref cipi (kk) ((1 4))))))
 126       (setf sti
 127               (+ (* c2r (f2cl-lib:fref cipi (kk) ((1 4))))
 128                  (* c2i (f2cl-lib:fref cipr (kk) ((1 4))))))
 129       (setf csr (- (* cr1r str) (* cr1i sti)))
 130       (setf csi (+ (* cr1r sti) (* cr1i str)))
 131       (if (> yy 0.0) (go label20))
 132       (setf znr (- znr))
 133       (setf zbi (- zbi))
 134      label20
 135       (setf j 2)
 136       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 137                     ((> i n) nil)
 138         (tagbody
 139           (setf j (f2cl-lib:int-sub 3 j))
 140           (setf fn (+ fnu (f2cl-lib:int-sub i 1)))
 141           (multiple-value-bind
 142                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 143                  var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 144               (zunhj znr zni fn 0 tol (f2cl-lib:fref phir (j) ((1 2)))
 145                (f2cl-lib:fref phii (j) ((1 2)))
 146                (f2cl-lib:fref argr (j) ((1 2)))
 147                (f2cl-lib:fref argi (j) ((1 2)))
 148                (f2cl-lib:fref zeta1r (j) ((1 2)))
 149                (f2cl-lib:fref zeta1i (j) ((1 2)))
 150                (f2cl-lib:fref zeta2r (j) ((1 2)))
 151                (f2cl-lib:fref zeta2i (j) ((1 2)))
 152                (f2cl-lib:fref asumr (j) ((1 2)))
 153                (f2cl-lib:fref asumi (j) ((1 2)))
 154                (f2cl-lib:fref bsumr (j) ((1 2)))
 155                (f2cl-lib:fref bsumi (j) ((1 2))))
 156             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 157             (setf (f2cl-lib:fref phir (j) ((1 2))) var-5)
 158             (setf (f2cl-lib:fref phii (j) ((1 2))) var-6)
 159             (setf (f2cl-lib:fref argr (j) ((1 2))) var-7)
 160             (setf (f2cl-lib:fref argi (j) ((1 2))) var-8)
 161             (setf (f2cl-lib:fref zeta1r (j) ((1 2))) var-9)
 162             (setf (f2cl-lib:fref zeta1i (j) ((1 2))) var-10)
 163             (setf (f2cl-lib:fref zeta2r (j) ((1 2))) var-11)
 164             (setf (f2cl-lib:fref zeta2i (j) ((1 2))) var-12)
 165             (setf (f2cl-lib:fref asumr (j) ((1 2))) var-13)
 166             (setf (f2cl-lib:fref asumi (j) ((1 2))) var-14)
 167             (setf (f2cl-lib:fref bsumr (j) ((1 2))) var-15)
 168             (setf (f2cl-lib:fref bsumi (j) ((1 2))) var-16))
 169           (if (= kode 1) (go label30))
 170           (setf str (+ zbr (f2cl-lib:fref zeta2r (j) ((1 2)))))
 171           (setf sti (+ zbi (f2cl-lib:fref zeta2i (j) ((1 2)))))
 172           (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 173           (setf str (* str rast rast))
 174           (setf sti (* (- sti) rast rast))
 175           (setf s1r (- (f2cl-lib:fref zeta1r (j) ((1 2))) str))
 176           (setf s1i (- (f2cl-lib:fref zeta1i (j) ((1 2))) sti))
 177           (go label40)
 178          label30
 179           (setf s1r
 180                   (- (f2cl-lib:fref zeta1r (j) ((1 2)))
 181                      (f2cl-lib:fref zeta2r (j) ((1 2)))))
 182           (setf s1i
 183                   (- (f2cl-lib:fref zeta1i (j) ((1 2)))
 184                      (f2cl-lib:fref zeta2i (j) ((1 2)))))
 185          label40
 186           (setf rs1 s1r)
 187           (if (> (abs rs1) elim) (go label70))
 188           (if (= kdflg 1) (setf kflag 2))
 189           (if (< (abs rs1) alim) (go label50))
 190           (setf aphi
 191                   (coerce
 192                    (realpart
 193                     (zabs (f2cl-lib:fref phir (j) ((1 2)))
 194                      (f2cl-lib:fref phii (j) ((1 2)))))
 195                    'double-float))
 196           (setf aarg
 197                   (coerce
 198                    (realpart
 199                     (zabs (f2cl-lib:fref argr (j) ((1 2)))
 200                      (f2cl-lib:fref argi (j) ((1 2)))))
 201                    'double-float))
 202           (setf rs1
 203                   (- (+ rs1 (f2cl-lib:flog aphi))
 204                      (* 0.25 (f2cl-lib:flog aarg))
 205                      aic))
 206           (if (> (abs rs1) elim) (go label70))
 207           (if (= kdflg 1) (setf kflag 1))
 208           (if (< rs1 0.0) (go label50))
 209           (if (= kdflg 1) (setf kflag 3))
 210          label50
 211           (setf c2r
 212                   (- (* (f2cl-lib:fref argr (j) ((1 2))) cr2r)
 213                      (* (f2cl-lib:fref argi (j) ((1 2))) cr2i)))
 214           (setf c2i
 215                   (+ (* (f2cl-lib:fref argr (j) ((1 2))) cr2i)
 216                      (* (f2cl-lib:fref argi (j) ((1 2))) cr2r)))
 217           (multiple-value-bind
 218                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 219               (zairy c2r c2i 0 2 air aii nai idum)
 220             (declare (ignore var-0 var-1 var-2 var-3))
 221             (setf air var-4)
 222             (setf aii var-5)
 223             (setf nai var-6)
 224             (setf idum var-7))
 225           (multiple-value-bind
 226                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 227               (zairy c2r c2i 1 2 dair daii ndai idum)
 228             (declare (ignore var-0 var-1 var-2 var-3))
 229             (setf dair var-4)
 230             (setf daii var-5)
 231             (setf ndai var-6)
 232             (setf idum var-7))
 233           (setf str
 234                   (- (* dair (f2cl-lib:fref bsumr (j) ((1 2))))
 235                      (* daii (f2cl-lib:fref bsumi (j) ((1 2))))))
 236           (setf sti
 237                   (+ (* dair (f2cl-lib:fref bsumi (j) ((1 2))))
 238                      (* daii (f2cl-lib:fref bsumr (j) ((1 2))))))
 239           (setf ptr (- (* str cr2r) (* sti cr2i)))
 240           (setf pti (+ (* str cr2i) (* sti cr2r)))
 241           (setf str
 242                   (+ ptr
 243                      (- (* air (f2cl-lib:fref asumr (j) ((1 2))))
 244                         (* aii (f2cl-lib:fref asumi (j) ((1 2)))))))
 245           (setf sti
 246                   (+ pti
 247                      (+ (* air (f2cl-lib:fref asumi (j) ((1 2))))
 248                         (* aii (f2cl-lib:fref asumr (j) ((1 2)))))))
 249           (setf ptr
 250                   (- (* str (f2cl-lib:fref phir (j) ((1 2))))
 251                      (* sti (f2cl-lib:fref phii (j) ((1 2))))))
 252           (setf pti
 253                   (+ (* str (f2cl-lib:fref phii (j) ((1 2))))
 254                      (* sti (f2cl-lib:fref phir (j) ((1 2))))))
 255           (setf s2r (- (* ptr csr) (* pti csi)))
 256           (setf s2i (+ (* ptr csi) (* pti csr)))
 257           (setf str (* (exp s1r) (f2cl-lib:fref cssr (kflag) ((1 3)))))
 258           (setf s1r (* str (cos s1i)))
 259           (setf s1i (* str (sin s1i)))
 260           (setf str (- (* s2r s1r) (* s2i s1i)))
 261           (setf s2i (+ (* s1r s2i) (* s2r s1i)))
 262           (setf s2r str)
 263           (if (/= kflag 1) (go label60))
 264           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 265               (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
 266             (declare (ignore var-0 var-1 var-3 var-4))
 267             (setf nw var-2))
 268           (if (/= nw 0) (go label70))
 269          label60
 270           (if (<= yy 0.0) (setf s2i (- s2i)))
 271           (setf (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
 272           (setf (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
 273           (setf (f2cl-lib:fref yr (i) ((1 n)))
 274                   (* s2r (f2cl-lib:fref csrr (kflag) ((1 3)))))
 275           (setf (f2cl-lib:fref yi (i) ((1 n)))
 276                   (* s2i (f2cl-lib:fref csrr (kflag) ((1 3)))))
 277           (setf str csi)
 278           (setf csi (- csr))
 279           (setf csr str)
 280           (if (= kdflg 2) (go label85))
 281           (setf kdflg 2)
 282           (go label80)
 283          label70
 284           (if (> rs1 0.0) (go label320))
 285           (if (< zr 0.0) (go label320))
 286           (setf kdflg 1)
 287           (setf (f2cl-lib:fref yr (i) ((1 n))) zeror)
 288           (setf (f2cl-lib:fref yi (i) ((1 n))) zeroi)
 289           (setf nz (f2cl-lib:int-add nz 1))
 290           (setf str csi)
 291           (setf csi (- csr))
 292           (setf csr str)
 293           (if (= i 1) (go label80))
 294           (if
 295            (and (= (f2cl-lib:fref yr ((f2cl-lib:int-sub i 1)) ((1 n))) zeror)
 296                 (= (f2cl-lib:fref yi ((f2cl-lib:int-sub i 1)) ((1 n))) zeroi))
 297            (go label80))
 298           (setf (f2cl-lib:fref yr ((f2cl-lib:int-sub i 1)) ((1 n))) zeror)
 299           (setf (f2cl-lib:fref yi ((f2cl-lib:int-sub i 1)) ((1 n))) zeroi)
 300           (setf nz (f2cl-lib:int-add nz 1))
 301          label80))
 302       (setf i n)
 303      label85
 304       (setf razr (coerce (realpart (/ 1.0 (zabs zrr zri))) 'double-float))
 305       (setf str (* zrr razr))
 306       (setf sti (* (- zri) razr))
 307       (setf rzr (* (+ str str) razr))
 308       (setf rzi (* (+ sti sti) razr))
 309       (setf ckr (* fn rzr))
 310       (setf cki (* fn rzi))
 311       (setf ib (f2cl-lib:int-add i 1))
 312       (if (< n ib) (go label180))
 313       (setf fn (+ fnu (f2cl-lib:int-sub n 1)))
 314       (setf ipard 1)
 315       (if (/= mr 0) (setf ipard 0))
 316       (multiple-value-bind
 317             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 318              var-11 var-12 var-13 var-14 var-15 var-16)
 319           (zunhj znr zni fn ipard tol phidr phidi argdr argdi zet1dr zet1di
 320            zet2dr zet2di asumdr asumdi bsumdr bsumdi)
 321         (declare (ignore var-0 var-1 var-2 var-3 var-4))
 322         (setf phidr var-5)
 323         (setf phidi var-6)
 324         (setf argdr var-7)
 325         (setf argdi var-8)
 326         (setf zet1dr var-9)
 327         (setf zet1di var-10)
 328         (setf zet2dr var-11)
 329         (setf zet2di var-12)
 330         (setf asumdr var-13)
 331         (setf asumdi var-14)
 332         (setf bsumdr var-15)
 333         (setf bsumdi var-16))
 334       (if (= kode 1) (go label90))
 335       (setf str (+ zbr zet2dr))
 336       (setf sti (+ zbi zet2di))
 337       (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 338       (setf str (* str rast rast))
 339       (setf sti (* (- sti) rast rast))
 340       (setf s1r (- zet1dr str))
 341       (setf s1i (- zet1di sti))
 342       (go label100)
 343      label90
 344       (setf s1r (- zet1dr zet2dr))
 345       (setf s1i (- zet1di zet2di))
 346      label100
 347       (setf rs1 s1r)
 348       (if (> (abs rs1) elim) (go label105))
 349       (if (< (abs rs1) alim) (go label120))
 350       (setf aphi (coerce (realpart (zabs phidr phidi)) 'double-float))
 351       (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
 352       (if (< (abs rs1) elim) (go label120))
 353      label105
 354       (if (> rs1 0.0) (go label320))
 355       (if (< zr 0.0) (go label320))
 356       (setf nz n)
 357       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 358                     ((> i n) nil)
 359         (tagbody
 360           (setf (f2cl-lib:fref yr (i) ((1 n))) zeror)
 361           (setf (f2cl-lib:fref yi (i) ((1 n))) zeroi)
 362          label106))
 363       (go end_label)
 364      label120
 365       (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
 366       (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
 367       (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
 368       (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
 369       (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
 370       (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
 371       (f2cl-lib:fdo (i ib (f2cl-lib:int-add i 1))
 372                     ((> i n) nil)
 373         (tagbody
 374           (setf c2r s2r)
 375           (setf c2i s2i)
 376           (setf s2r (+ (- (* ckr c2r) (* cki c2i)) s1r))
 377           (setf s2i (+ (* ckr c2i) (* cki c2r) s1i))
 378           (setf s1r c2r)
 379           (setf s1i c2i)
 380           (setf ckr (+ ckr rzr))
 381           (setf cki (+ cki rzi))
 382           (setf c2r (* s2r c1r))
 383           (setf c2i (* s2i c1r))
 384           (setf (f2cl-lib:fref yr (i) ((1 n))) c2r)
 385           (setf (f2cl-lib:fref yi (i) ((1 n))) c2i)
 386           (if (>= kflag 3) (go label130))
 387           (setf str (abs c2r))
 388           (setf sti (abs c2i))
 389           (setf c2m (max str sti))
 390           (if (<= c2m ascle) (go label130))
 391           (setf kflag (f2cl-lib:int-add kflag 1))
 392           (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
 393           (setf s1r (* s1r c1r))
 394           (setf s1i (* s1i c1r))
 395           (setf s2r c2r)
 396           (setf s2i c2i)
 397           (setf s1r (* s1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 398           (setf s1i (* s1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 399           (setf s2r (* s2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 400           (setf s2i (* s2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 401           (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
 402          label130))
 403      label180
 404       (if (= mr 0) (go end_label))
 405       (setf nz 0)
 406       (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
 407       (setf sgn (coerce (- (f2cl-lib:dsign pi$ fmr)) 'double-float))
 408       (setf csgni sgn)
 409       (if (<= yy 0.0) (setf csgni (- csgni)))
 410       (setf ifn (f2cl-lib:int-sub (f2cl-lib:int-add inu n) 1))
 411       (setf ang (* fnf sgn))
 412       (setf cspnr (cos ang))
 413       (setf cspni (sin ang))
 414       (if (= (mod ifn 2) 0) (go label190))
 415       (setf cspnr (- cspnr))
 416       (setf cspni (- cspni))
 417      label190
 418       (setf csr (* sar csgni))
 419       (setf csi (* car$ csgni))
 420       (setf in (f2cl-lib:int-add (mod ifn 4) 1))
 421       (setf c2r (f2cl-lib:fref cipr (in) ((1 4))))
 422       (setf c2i (f2cl-lib:fref cipi (in) ((1 4))))
 423       (setf str (+ (* csr c2r) (* csi c2i)))
 424       (setf csi (+ (* (- csr) c2i) (* csi c2r)))
 425       (setf csr str)
 426       (setf asc (f2cl-lib:fref bry (1) ((1 3))))
 427       (setf iuf 0)
 428       (setf kk n)
 429       (setf kdflg 1)
 430       (setf ib (f2cl-lib:int-sub ib 1))
 431       (setf ic (f2cl-lib:int-sub ib 1))
 432       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 433                     ((> k n) nil)
 434         (tagbody
 435           (setf fn (+ fnu (f2cl-lib:int-sub kk 1)))
 436           (if (> n 2) (go label175))
 437          label172
 438           (setf phidr (f2cl-lib:fref phir (j) ((1 2))))
 439           (setf phidi (f2cl-lib:fref phii (j) ((1 2))))
 440           (setf argdr (f2cl-lib:fref argr (j) ((1 2))))
 441           (setf argdi (f2cl-lib:fref argi (j) ((1 2))))
 442           (setf zet1dr (f2cl-lib:fref zeta1r (j) ((1 2))))
 443           (setf zet1di (f2cl-lib:fref zeta1i (j) ((1 2))))
 444           (setf zet2dr (f2cl-lib:fref zeta2r (j) ((1 2))))
 445           (setf zet2di (f2cl-lib:fref zeta2i (j) ((1 2))))
 446           (setf asumdr (f2cl-lib:fref asumr (j) ((1 2))))
 447           (setf asumdi (f2cl-lib:fref asumi (j) ((1 2))))
 448           (setf bsumdr (f2cl-lib:fref bsumr (j) ((1 2))))
 449           (setf bsumdi (f2cl-lib:fref bsumi (j) ((1 2))))
 450           (setf j (f2cl-lib:int-sub 3 j))
 451           (go label210)
 452          label175
 453           (if (and (= kk n) (< ib n)) (go label210))
 454           (if (or (= kk ib) (= kk ic)) (go label172))
 455           (multiple-value-bind
 456                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 457                  var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 458               (zunhj znr zni fn 0 tol phidr phidi argdr argdi zet1dr zet1di
 459                zet2dr zet2di asumdr asumdi bsumdr bsumdi)
 460             (declare (ignore var-0 var-1 var-2 var-3 var-4))
 461             (setf phidr var-5)
 462             (setf phidi var-6)
 463             (setf argdr var-7)
 464             (setf argdi var-8)
 465             (setf zet1dr var-9)
 466             (setf zet1di var-10)
 467             (setf zet2dr var-11)
 468             (setf zet2di var-12)
 469             (setf asumdr var-13)
 470             (setf asumdi var-14)
 471             (setf bsumdr var-15)
 472             (setf bsumdi var-16))
 473          label210
 474           (if (= kode 1) (go label220))
 475           (setf str (+ zbr zet2dr))
 476           (setf sti (+ zbi zet2di))
 477           (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 478           (setf str (* str rast rast))
 479           (setf sti (* (- sti) rast rast))
 480           (setf s1r (- str zet1dr))
 481           (setf s1i (- sti zet1di))
 482           (go label230)
 483          label220
 484           (setf s1r (- zet2dr zet1dr))
 485           (setf s1i (- zet2di zet1di))
 486          label230
 487           (setf rs1 s1r)
 488           (if (> (abs rs1) elim) (go label280))
 489           (if (= kdflg 1) (setf iflag 2))
 490           (if (< (abs rs1) alim) (go label240))
 491           (setf aphi (coerce (realpart (zabs phidr phidi)) 'double-float))
 492           (setf aarg (coerce (realpart (zabs argdr argdi)) 'double-float))
 493           (setf rs1
 494                   (- (+ rs1 (f2cl-lib:flog aphi))
 495                      (* 0.25 (f2cl-lib:flog aarg))
 496                      aic))
 497           (if (> (abs rs1) elim) (go label280))
 498           (if (= kdflg 1) (setf iflag 1))
 499           (if (< rs1 0.0) (go label240))
 500           (if (= kdflg 1) (setf iflag 3))
 501          label240
 502           (multiple-value-bind
 503                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 504               (zairy argdr argdi 0 2 air aii nai idum)
 505             (declare (ignore var-0 var-1 var-2 var-3))
 506             (setf air var-4)
 507             (setf aii var-5)
 508             (setf nai var-6)
 509             (setf idum var-7))
 510           (multiple-value-bind
 511                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 512               (zairy argdr argdi 1 2 dair daii ndai idum)
 513             (declare (ignore var-0 var-1 var-2 var-3))
 514             (setf dair var-4)
 515             (setf daii var-5)
 516             (setf ndai var-6)
 517             (setf idum var-7))
 518           (setf str (- (* dair bsumdr) (* daii bsumdi)))
 519           (setf sti (+ (* dair bsumdi) (* daii bsumdr)))
 520           (setf str (+ str (- (* air asumdr) (* aii asumdi))))
 521           (setf sti (+ sti (+ (* air asumdi) (* aii asumdr))))
 522           (setf ptr (- (* str phidr) (* sti phidi)))
 523           (setf pti (+ (* str phidi) (* sti phidr)))
 524           (setf s2r (- (* ptr csr) (* pti csi)))
 525           (setf s2i (+ (* ptr csi) (* pti csr)))
 526           (setf str (* (exp s1r) (f2cl-lib:fref cssr (iflag) ((1 3)))))
 527           (setf s1r (* str (cos s1i)))
 528           (setf s1i (* str (sin s1i)))
 529           (setf str (- (* s2r s1r) (* s2i s1i)))
 530           (setf s2i (+ (* s2r s1i) (* s2i s1r)))
 531           (setf s2r str)
 532           (if (/= iflag 1) (go label250))
 533           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 534               (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
 535             (declare (ignore var-0 var-1 var-3 var-4))
 536             (setf nw var-2))
 537           (if (= nw 0) (go label250))
 538           (setf s2r zeror)
 539           (setf s2i zeroi)
 540          label250
 541           (if (<= yy 0.0) (setf s2i (- s2i)))
 542           (setf (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
 543           (setf (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
 544           (setf c2r s2r)
 545           (setf c2i s2i)
 546           (setf s2r (* s2r (f2cl-lib:fref csrr (iflag) ((1 3)))))
 547           (setf s2i (* s2i (f2cl-lib:fref csrr (iflag) ((1 3)))))
 548           (setf s1r (f2cl-lib:fref yr (kk) ((1 n))))
 549           (setf s1i (f2cl-lib:fref yi (kk) ((1 n))))
 550           (if (= kode 1) (go label270))
 551           (multiple-value-bind
 552                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 553               (zs1s2 zrr zri s1r s1i s2r s2i nw asc alim iuf)
 554             (declare (ignore var-0 var-1 var-7 var-8))
 555             (setf s1r var-2)
 556             (setf s1i var-3)
 557             (setf s2r var-4)
 558             (setf s2i var-5)
 559             (setf nw var-6)
 560             (setf iuf var-9))
 561           (setf nz (f2cl-lib:int-add nz nw))
 562          label270
 563           (setf (f2cl-lib:fref yr (kk) ((1 n)))
 564                   (+ (- (* s1r cspnr) (* s1i cspni)) s2r))
 565           (setf (f2cl-lib:fref yi (kk) ((1 n)))
 566                   (+ (* s1r cspni) (* s1i cspnr) s2i))
 567           (setf kk (f2cl-lib:int-sub kk 1))
 568           (setf cspnr (- cspnr))
 569           (setf cspni (- cspni))
 570           (setf str csi)
 571           (setf csi (- csr))
 572           (setf csr str)
 573           (if (or (/= c2r 0.0) (/= c2i 0.0)) (go label255))
 574           (setf kdflg 1)
 575           (go label290)
 576          label255
 577           (if (= kdflg 2) (go label295))
 578           (setf kdflg 2)
 579           (go label290)
 580          label280
 581           (if (> rs1 0.0) (go label320))
 582           (setf s2r zeror)
 583           (setf s2i zeroi)
 584           (go label250)
 585          label290))
 586       (setf k n)
 587      label295
 588       (setf il (f2cl-lib:int-sub n k))
 589       (if (= il 0) (go end_label))
 590       (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
 591       (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
 592       (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
 593       (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
 594       (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
 595       (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 596       (setf fn
 597               (coerce (the f2cl-lib:integer4 (f2cl-lib:int-add inu il))
 598                       'double-float))
 599       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 600                     ((> i il) nil)
 601         (tagbody
 602           (setf c2r s2r)
 603           (setf c2i s2i)
 604           (setf s2r (+ s1r (* (+ fn fnf) (- (* rzr c2r) (* rzi c2i)))))
 605           (setf s2i (+ s1i (* (+ fn fnf) (+ (* rzr c2i) (* rzi c2r)))))
 606           (setf s1r c2r)
 607           (setf s1i c2i)
 608           (setf fn (- fn 1.0))
 609           (setf c2r (* s2r csr))
 610           (setf c2i (* s2i csr))
 611           (setf ckr c2r)
 612           (setf cki c2i)
 613           (setf c1r (f2cl-lib:fref yr (kk) ((1 n))))
 614           (setf c1i (f2cl-lib:fref yi (kk) ((1 n))))
 615           (if (= kode 1) (go label300))
 616           (multiple-value-bind
 617                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 618               (zs1s2 zrr zri c1r c1i c2r c2i nw asc alim iuf)
 619             (declare (ignore var-0 var-1 var-7 var-8))
 620             (setf c1r var-2)
 621             (setf c1i var-3)
 622             (setf c2r var-4)
 623             (setf c2i var-5)
 624             (setf nw var-6)
 625             (setf iuf var-9))
 626           (setf nz (f2cl-lib:int-add nz nw))
 627          label300
 628           (setf (f2cl-lib:fref yr (kk) ((1 n)))
 629                   (+ (- (* c1r cspnr) (* c1i cspni)) c2r))
 630           (setf (f2cl-lib:fref yi (kk) ((1 n)))
 631                   (+ (* c1r cspni) (* c1i cspnr) c2i))
 632           (setf kk (f2cl-lib:int-sub kk 1))
 633           (setf cspnr (- cspnr))
 634           (setf cspni (- cspni))
 635           (if (>= iflag 3) (go label310))
 636           (setf c2r (abs ckr))
 637           (setf c2i (abs cki))
 638           (setf c2m (max c2r c2i))
 639           (if (<= c2m ascle) (go label310))
 640           (setf iflag (f2cl-lib:int-add iflag 1))
 641           (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 642           (setf s1r (* s1r csr))
 643           (setf s1i (* s1i csr))
 644           (setf s2r ckr)
 645           (setf s2i cki)
 646           (setf s1r (* s1r (f2cl-lib:fref cssr (iflag) ((1 3)))))
 647           (setf s1i (* s1i (f2cl-lib:fref cssr (iflag) ((1 3)))))
 648           (setf s2r (* s2r (f2cl-lib:fref cssr (iflag) ((1 3)))))
 649           (setf s2i (* s2i (f2cl-lib:fref cssr (iflag) ((1 3)))))
 650           (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
 651          label310))
 652       (go end_label)
 653      label320
 654       (setf nz -1)
 655       (go end_label)
 656      end_label
 657       (return (values nil nil nil nil nil nil nil nil nz nil nil nil)))))
 658
 659 (in-package #:cl-user)
 660 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 661 (eval-when (:load-toplevel :compile-toplevel :execute)
 662   (setf (gethash 'fortran-to-lisp::zunk2 fortran-to-lisp::*f2cl-function-info*)
 663           (fortran-to-lisp::make-f2cl-finfo
 664            :arg-types '((double-float) (double-float) (double-float)
 665                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 666                         (fortran-to-lisp::integer4)
 667                         (simple-array double-float (*))
 668                         (simple-array double-float (*))
 669                         (fortran-to-lisp::integer4) (double-float)
 670                         (double-float) (double-float))
 671            :return-values '(nil nil nil nil nil nil nil nil fortran-to-lisp::nz
 672                             nil nil nil)
 673            :calls '(fortran-to-lisp::zs1s2 fortran-to-lisp::zuchk
 674                     fortran-to-lisp::zairy fortran-to-lisp::zabs
 675                     fortran-to-lisp::zunhj fortran-to-lisp::d1mach))))
 676