src/numerical/slatec/zunk1.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 (let ((zeror 0.0) (zeroi 0.0) (coner 1.0) (pi$ 3.141592653589793))
  21   (declare (type (double-float) zeror zeroi coner pi$))
  22   (defun zunk1 (zr zi fnu kode mr n yr yi nz tol elim alim)
  23     (declare (type (array double-float (*)) yi yr)
  24              (type (f2cl-lib:integer4) nz n mr kode)
  25              (type (double-float) alim elim tol fnu zi zr))
  26     (f2cl-lib:with-multi-array-data
  27         ((yr double-float yr-%data% yr-%offset%)
  28          (yi double-float yi-%data% yi-%offset%))
  29       (prog ((bry (make-array 3 :element-type 'double-float))
  30              (init (make-array 2 :element-type 'f2cl-lib:integer4))
  31              (sumr (make-array 2 :element-type 'double-float))
  32              (sumi (make-array 2 :element-type 'double-float))
  33              (zeta1r (make-array 2 :element-type 'double-float))
  34              (zeta1i (make-array 2 :element-type 'double-float))
  35              (zeta2r (make-array 2 :element-type 'double-float))
  36              (zeta2i (make-array 2 :element-type 'double-float))
  37              (cyr (make-array 2 :element-type 'double-float))
  38              (cyi (make-array 2 :element-type 'double-float))
  39              (cwrkr (make-array 48 :element-type 'double-float))
  40              (cwrki (make-array 48 :element-type 'double-float))
  41              (cssr (make-array 3 :element-type 'double-float))
  42              (csrr (make-array 3 :element-type 'double-float))
  43              (phir (make-array 2 :element-type 'double-float))
  44              (phii (make-array 2 :element-type 'double-float)) (i 0) (ib 0)
  45              (iflag 0) (ifn 0) (il 0) (inu 0) (iuf 0) (k 0) (kdflg 0) (kflag 0)
  46              (kk 0) (nw 0) (initd 0) (ic 0) (ipard 0) (j 0) (m 0) (ang 0.0)
  47              (aphi 0.0) (asc 0.0) (ascle 0.0) (cki 0.0) (ckr 0.0) (crsc 0.0)
  48              (cscl 0.0) (csgni 0.0) (cspni 0.0) (cspnr 0.0) (csr 0.0) (c1i 0.0)
  49              (c1r 0.0) (c2i 0.0) (c2m 0.0) (c2r 0.0) (fmr 0.0) (fn 0.0)
  50              (fnf 0.0) (phidi 0.0) (phidr 0.0) (rast 0.0) (razr 0.0) (rs1 0.0)
  51              (rzi 0.0) (rzr 0.0) (sgn 0.0) (sti 0.0) (str 0.0) (sumdi 0.0)
  52              (sumdr 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0) (zet1di 0.0)
  53              (zet1dr 0.0) (zet2di 0.0) (zet2dr 0.0) (zri 0.0) (zrr 0.0))
  54         (declare (type (array double-float (2)) zeta2r zeta2i zeta1r zeta1i
  55                                                 sumr sumi phir phii cyr cyi)
  56                  (type (array double-float (48)) cwrkr cwrki)
  57                  (type (array double-float (3)) cssr csrr bry)
  58                  (type (double-float) zrr zri zet2dr zet2di zet1dr zet1di s2r
  59                                       s2i s1r s1i sumdr sumdi str sti sgn rzr
  60                                       rzi rs1 razr rast phidr phidi fnf fn fmr
  61                                       c2r c2m c2i c1r c1i csr cspnr cspni csgni
  62                                       cscl crsc ckr cki ascle asc aphi ang)
  63                  (type (array f2cl-lib:integer4 (2)) init)
  64                  (type (f2cl-lib:integer4) m j ipard ic initd nw kk kflag kdflg
  65                                            k iuf inu il ifn iflag ib i))
  66         (setf kdflg 1)
  67         (setf nz 0)
  68         (setf cscl (/ 1.0 tol))
  69         (setf crsc tol)
  70         (setf (f2cl-lib:fref cssr (1) ((1 3))) cscl)
  71         (setf (f2cl-lib:fref cssr (2) ((1 3))) coner)
  72         (setf (f2cl-lib:fref cssr (3) ((1 3))) crsc)
  73         (setf (f2cl-lib:fref csrr (1) ((1 3))) crsc)
  74         (setf (f2cl-lib:fref csrr (2) ((1 3))) coner)
  75         (setf (f2cl-lib:fref csrr (3) ((1 3))) cscl)
  76         (setf (f2cl-lib:fref bry (1) ((1 3)))
  77                 (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  78         (setf (f2cl-lib:fref bry (2) ((1 3)))
  79                 (/ 1.0 (f2cl-lib:fref bry (1) ((1 3)))))
  80         (setf (f2cl-lib:fref bry (3) ((1 3))) (f2cl-lib:d1mach 2))
  81         (setf zrr zr)
  82         (setf zri zi)
  83         (if (>= zr 0.0) (go label10))
  84         (setf zrr (- zr))
  85         (setf zri (- zi))
  86        label10
  87         (setf j 2)
  88         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  89                       ((> i n) nil)
  90           (tagbody
  91             (setf j (f2cl-lib:int-sub 3 j))
  92             (setf fn (+ fnu (f2cl-lib:int-sub i 1)))
  93             (setf (f2cl-lib:fref init (j) ((1 2))) 0)
  94             (multiple-value-bind
  95                   (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  96                    var-10 var-11 var-12 var-13 var-14 var-15 var-16)
  97                 (zunik zrr zri fn 2 0 tol (f2cl-lib:fref init (j) ((1 2)))
  98                  (f2cl-lib:fref phir (j) ((1 2)))
  99                  (f2cl-lib:fref phii (j) ((1 2)))
 100                  (f2cl-lib:fref zeta1r (j) ((1 2)))
 101                  (f2cl-lib:fref zeta1i (j) ((1 2)))
 102                  (f2cl-lib:fref zeta2r (j) ((1 2)))
 103                  (f2cl-lib:fref zeta2i (j) ((1 2)))
 104                  (f2cl-lib:fref sumr (j) ((1 2)))
 105                  (f2cl-lib:fref sumi (j) ((1 2)))
 106                  (f2cl-lib:array-slice cwrkr double-float (1 j) ((1 16) (1 3)))
 107                  (f2cl-lib:array-slice cwrki
 108                                        double-float
 109                                        (1 j)
 110                                        ((1 16) (1 3))))
 111               (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15
 112                                var-16))
 113               (setf (f2cl-lib:fref init (j) ((1 2))) var-6)
 114               (setf (f2cl-lib:fref phir (j) ((1 2))) var-7)
 115               (setf (f2cl-lib:fref phii (j) ((1 2))) var-8)
 116               (setf (f2cl-lib:fref zeta1r (j) ((1 2))) var-9)
 117               (setf (f2cl-lib:fref zeta1i (j) ((1 2))) var-10)
 118               (setf (f2cl-lib:fref zeta2r (j) ((1 2))) var-11)
 119               (setf (f2cl-lib:fref zeta2i (j) ((1 2))) var-12)
 120               (setf (f2cl-lib:fref sumr (j) ((1 2))) var-13)
 121               (setf (f2cl-lib:fref sumi (j) ((1 2))) var-14))
 122             (if (= kode 1) (go label20))
 123             (setf str (+ zrr (f2cl-lib:fref zeta2r (j) ((1 2)))))
 124             (setf sti (+ zri (f2cl-lib:fref zeta2i (j) ((1 2)))))
 125             (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 126             (setf str (* str rast rast))
 127             (setf sti (* (- sti) rast rast))
 128             (setf s1r (- (f2cl-lib:fref zeta1r (j) ((1 2))) str))
 129             (setf s1i (- (f2cl-lib:fref zeta1i (j) ((1 2))) sti))
 130             (go label30)
 131            label20
 132             (setf s1r
 133                     (- (f2cl-lib:fref zeta1r (j) ((1 2)))
 134                        (f2cl-lib:fref zeta2r (j) ((1 2)))))
 135             (setf s1i
 136                     (- (f2cl-lib:fref zeta1i (j) ((1 2)))
 137                        (f2cl-lib:fref zeta2i (j) ((1 2)))))
 138            label30
 139             (setf rs1 s1r)
 140             (if (> (abs rs1) elim) (go label60))
 141             (if (= kdflg 1) (setf kflag 2))
 142             (if (< (abs rs1) alim) (go label40))
 143             (setf aphi
 144                     (coerce
 145                      (realpart
 146                       (zabs (f2cl-lib:fref phir (j) ((1 2)))
 147                        (f2cl-lib:fref phii (j) ((1 2)))))
 148                      'double-float))
 149             (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
 150             (if (> (abs rs1) elim) (go label60))
 151             (if (= kdflg 1) (setf kflag 1))
 152             (if (< rs1 0.0) (go label40))
 153             (if (= kdflg 1) (setf kflag 3))
 154            label40
 155             (setf s2r
 156                     (-
 157                      (* (f2cl-lib:fref phir (j) ((1 2)))
 158                         (f2cl-lib:fref sumr (j) ((1 2))))
 159                      (* (f2cl-lib:fref phii (j) ((1 2)))
 160                         (f2cl-lib:fref sumi (j) ((1 2))))))
 161             (setf s2i
 162                     (+
 163                      (* (f2cl-lib:fref phir (j) ((1 2)))
 164                         (f2cl-lib:fref sumi (j) ((1 2))))
 165                      (* (f2cl-lib:fref phii (j) ((1 2)))
 166                         (f2cl-lib:fref sumr (j) ((1 2))))))
 167             (setf str (* (exp s1r) (f2cl-lib:fref cssr (kflag) ((1 3)))))
 168             (setf s1r (* str (cos s1i)))
 169             (setf s1i (* str (sin s1i)))
 170             (setf str (- (* s2r s1r) (* s2i s1i)))
 171             (setf s2i (+ (* s1r s2i) (* s2r s1i)))
 172             (setf s2r str)
 173             (if (/= kflag 1) (go label50))
 174             (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 175                 (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
 176               (declare (ignore var-0 var-1 var-3 var-4))
 177               (setf nw var-2))
 178             (if (/= nw 0) (go label60))
 179            label50
 180             (setf (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
 181             (setf (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
 182             (setf (f2cl-lib:fref yr-%data% (i) ((1 n)) yr-%offset%)
 183                     (* s2r (f2cl-lib:fref csrr (kflag) ((1 3)))))
 184             (setf (f2cl-lib:fref yi-%data% (i) ((1 n)) yi-%offset%)
 185                     (* s2i (f2cl-lib:fref csrr (kflag) ((1 3)))))
 186             (if (= kdflg 2) (go label75))
 187             (setf kdflg 2)
 188             (go label70)
 189            label60
 190             (if (> rs1 0.0) (go label300))
 191             (if (< zr 0.0) (go label300))
 192             (setf kdflg 1)
 193             (setf (f2cl-lib:fref yr-%data% (i) ((1 n)) yr-%offset%) zeror)
 194             (setf (f2cl-lib:fref yi-%data% (i) ((1 n)) yi-%offset%) zeroi)
 195             (setf nz (f2cl-lib:int-add nz 1))
 196             (if (= i 1) (go label70))
 197             (if
 198              (and
 199               (=
 200                (f2cl-lib:fref yr-%data%
 201                               ((f2cl-lib:int-sub i 1))
 202                               ((1 n))
 203                               yr-%offset%)
 204                zeror)
 205               (=
 206                (f2cl-lib:fref yi-%data%
 207                               ((f2cl-lib:int-sub i 1))
 208                               ((1 n))
 209                               yi-%offset%)
 210                zeroi))
 211              (go label70))
 212             (setf (f2cl-lib:fref yr-%data%
 213                                  ((f2cl-lib:int-sub i 1))
 214                                  ((1 n))
 215                                  yr-%offset%)
 216                     zeror)
 217             (setf (f2cl-lib:fref yi-%data%
 218                                  ((f2cl-lib:int-sub i 1))
 219                                  ((1 n))
 220                                  yi-%offset%)
 221                     zeroi)
 222             (setf nz (f2cl-lib:int-add nz 1))
 223            label70))
 224         (setf i n)
 225        label75
 226         (setf razr (coerce (realpart (/ 1.0 (zabs zrr zri))) 'double-float))
 227         (setf str (* zrr razr))
 228         (setf sti (* (- zri) razr))
 229         (setf rzr (* (+ str str) razr))
 230         (setf rzi (* (+ sti sti) razr))
 231         (setf ckr (* fn rzr))
 232         (setf cki (* fn rzi))
 233         (setf ib (f2cl-lib:int-add i 1))
 234         (if (< n ib) (go label160))
 235         (setf fn (+ fnu (f2cl-lib:int-sub n 1)))
 236         (setf ipard 1)
 237         (if (/= mr 0) (setf ipard 0))
 238         (setf initd 0)
 239         (multiple-value-bind
 240               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 241                var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 242             (zunik zrr zri fn 2 ipard tol initd phidr phidi zet1dr zet1di
 243              zet2dr zet2di sumdr sumdi
 244              (f2cl-lib:array-slice cwrkr double-float (1 3) ((1 16) (1 3)))
 245              (f2cl-lib:array-slice cwrki double-float (1 3) ((1 16) (1 3))))
 246           (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
 247           (setf initd var-6)
 248           (setf phidr var-7)
 249           (setf phidi var-8)
 250           (setf zet1dr var-9)
 251           (setf zet1di var-10)
 252           (setf zet2dr var-11)
 253           (setf zet2di var-12)
 254           (setf sumdr var-13)
 255           (setf sumdi var-14))
 256         (if (= kode 1) (go label80))
 257         (setf str (+ zrr zet2dr))
 258         (setf sti (+ zri zet2di))
 259         (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 260         (setf str (* str rast rast))
 261         (setf sti (* (- sti) rast rast))
 262         (setf s1r (- zet1dr str))
 263         (setf s1i (- zet1di sti))
 264         (go label90)
 265        label80
 266         (setf s1r (- zet1dr zet2dr))
 267         (setf s1i (- zet1di zet2di))
 268        label90
 269         (setf rs1 s1r)
 270         (if (> (abs rs1) elim) (go label95))
 271         (if (< (abs rs1) alim) (go label100))
 272         (setf aphi (coerce (realpart (zabs phidr phidi)) 'double-float))
 273         (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
 274         (if (< (abs rs1) elim) (go label100))
 275        label95
 276         (if (> (abs rs1) 0.0) (go label300))
 277         (if (< zr 0.0) (go label300))
 278         (setf nz n)
 279         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 280                       ((> i n) nil)
 281           (tagbody
 282             (setf (f2cl-lib:fref yr-%data% (i) ((1 n)) yr-%offset%) zeror)
 283             (setf (f2cl-lib:fref yi-%data% (i) ((1 n)) yi-%offset%) zeroi)
 284            label96))
 285         (go end_label)
 286        label100
 287         (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
 288         (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
 289         (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
 290         (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
 291         (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
 292         (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
 293         (f2cl-lib:fdo (i ib (f2cl-lib:int-add i 1))
 294                       ((> i n) nil)
 295           (tagbody
 296             (setf c2r s2r)
 297             (setf c2i s2i)
 298             (setf s2r (+ (- (* ckr c2r) (* cki c2i)) s1r))
 299             (setf s2i (+ (* ckr c2i) (* cki c2r) s1i))
 300             (setf s1r c2r)
 301             (setf s1i c2i)
 302             (setf ckr (+ ckr rzr))
 303             (setf cki (+ cki rzi))
 304             (setf c2r (* s2r c1r))
 305             (setf c2i (* s2i c1r))
 306             (setf (f2cl-lib:fref yr-%data% (i) ((1 n)) yr-%offset%) c2r)
 307             (setf (f2cl-lib:fref yi-%data% (i) ((1 n)) yi-%offset%) c2i)
 308             (if (>= kflag 3) (go label120))
 309             (setf str (abs c2r))
 310             (setf sti (abs c2i))
 311             (setf c2m (max str sti))
 312             (if (<= c2m ascle) (go label120))
 313             (setf kflag (f2cl-lib:int-add kflag 1))
 314             (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
 315             (setf s1r (* s1r c1r))
 316             (setf s1i (* s1i c1r))
 317             (setf s2r c2r)
 318             (setf s2i c2i)
 319             (setf s1r (* s1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 320             (setf s1i (* s1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 321             (setf s2r (* s2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
 322             (setf s2i (* s2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
 323             (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
 324            label120))
 325        label160
 326         (if (= mr 0) (go end_label))
 327         (setf nz 0)
 328         (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
 329         (setf sgn (coerce (- (f2cl-lib:dsign pi$ fmr)) 'double-float))
 330         (setf csgni sgn)
 331         (setf inu (f2cl-lib:int fnu))
 332         (setf fnf (- fnu inu))
 333         (setf ifn (f2cl-lib:int-sub (f2cl-lib:int-add inu n) 1))
 334         (setf ang (* fnf sgn))
 335         (setf cspnr (cos ang))
 336         (setf cspni (sin ang))
 337         (if (= (mod ifn 2) 0) (go label170))
 338         (setf cspnr (- cspnr))
 339         (setf cspni (- cspni))
 340        label170
 341         (setf asc (f2cl-lib:fref bry (1) ((1 3))))
 342         (setf iuf 0)
 343         (setf kk n)
 344         (setf kdflg 1)
 345         (setf ib (f2cl-lib:int-sub ib 1))
 346         (setf ic (f2cl-lib:int-sub ib 1))
 347         (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 348                       ((> k n) nil)
 349           (tagbody
 350             (setf fn (+ fnu (f2cl-lib:int-sub kk 1)))
 351             (setf m 3)
 352             (if (> n 2) (go label175))
 353            label172
 354             (setf initd (f2cl-lib:fref init (j) ((1 2))))
 355             (setf phidr (f2cl-lib:fref phir (j) ((1 2))))
 356             (setf phidi (f2cl-lib:fref phii (j) ((1 2))))
 357             (setf zet1dr (f2cl-lib:fref zeta1r (j) ((1 2))))
 358             (setf zet1di (f2cl-lib:fref zeta1i (j) ((1 2))))
 359             (setf zet2dr (f2cl-lib:fref zeta2r (j) ((1 2))))
 360             (setf zet2di (f2cl-lib:fref zeta2i (j) ((1 2))))
 361             (setf sumdr (f2cl-lib:fref sumr (j) ((1 2))))
 362             (setf sumdi (f2cl-lib:fref sumi (j) ((1 2))))
 363             (setf m j)
 364             (setf j (f2cl-lib:int-sub 3 j))
 365             (go label180)
 366            label175
 367             (if (and (= kk n) (< ib n)) (go label180))
 368             (if (or (= kk ib) (= kk ic)) (go label172))
 369             (setf initd 0)
 370            label180
 371             (multiple-value-bind
 372                   (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 373                    var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 374                 (zunik zrr zri fn 1 0 tol initd phidr phidi zet1dr zet1di
 375                  zet2dr zet2di sumdr sumdi
 376                  (f2cl-lib:array-slice cwrkr double-float (1 m) ((1 16) (1 3)))
 377                  (f2cl-lib:array-slice cwrki
 378                                        double-float
 379                                        (1 m)
 380                                        ((1 16) (1 3))))
 381               (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15
 382                                var-16))
 383               (setf initd var-6)
 384               (setf phidr var-7)
 385               (setf phidi var-8)
 386               (setf zet1dr var-9)
 387               (setf zet1di var-10)
 388               (setf zet2dr var-11)
 389               (setf zet2di var-12)
 390               (setf sumdr var-13)
 391               (setf sumdi var-14))
 392             (if (= kode 1) (go label200))
 393             (setf str (+ zrr zet2dr))
 394             (setf sti (+ zri zet2di))
 395             (setf rast (coerce (realpart (/ fn (zabs str sti))) 'double-float))
 396             (setf str (* str rast rast))
 397             (setf sti (* (- sti) rast rast))
 398             (setf s1r (- str zet1dr))
 399             (setf s1i (- sti zet1di))
 400             (go label210)
 401            label200
 402             (setf s1r (- zet2dr zet1dr))
 403             (setf s1i (- zet2di zet1di))
 404            label210
 405             (setf rs1 s1r)
 406             (if (> (abs rs1) elim) (go label260))
 407             (if (= kdflg 1) (setf iflag 2))
 408             (if (< (abs rs1) alim) (go label220))
 409             (setf aphi (coerce (realpart (zabs phidr phidi)) 'double-float))
 410             (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
 411             (if (> (abs rs1) elim) (go label260))
 412             (if (= kdflg 1) (setf iflag 1))
 413             (if (< rs1 0.0) (go label220))
 414             (if (= kdflg 1) (setf iflag 3))
 415            label220
 416             (setf str (- (* phidr sumdr) (* phidi sumdi)))
 417             (setf sti (+ (* phidr sumdi) (* phidi sumdr)))
 418             (setf s2r (* (- csgni) sti))
 419             (setf s2i (* csgni str))
 420             (setf str (* (exp s1r) (f2cl-lib:fref cssr (iflag) ((1 3)))))
 421             (setf s1r (* str (cos s1i)))
 422             (setf s1i (* str (sin s1i)))
 423             (setf str (- (* s2r s1r) (* s2i s1i)))
 424             (setf s2i (+ (* s2r s1i) (* s2i s1r)))
 425             (setf s2r str)
 426             (if (/= iflag 1) (go label230))
 427             (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 428                 (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
 429               (declare (ignore var-0 var-1 var-3 var-4))
 430               (setf nw var-2))
 431             (if (= nw 0) (go label230))
 432             (setf s2r zeror)
 433             (setf s2i zeroi)
 434            label230
 435             (setf (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
 436             (setf (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
 437             (setf c2r s2r)
 438             (setf c2i s2i)
 439             (setf s2r (* s2r (f2cl-lib:fref csrr (iflag) ((1 3)))))
 440             (setf s2i (* s2i (f2cl-lib:fref csrr (iflag) ((1 3)))))
 441             (setf s1r (f2cl-lib:fref yr-%data% (kk) ((1 n)) yr-%offset%))
 442             (setf s1i (f2cl-lib:fref yi-%data% (kk) ((1 n)) yi-%offset%))
 443             (if (= kode 1) (go label250))
 444             (multiple-value-bind
 445                   (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 446                 (zs1s2 zrr zri s1r s1i s2r s2i nw asc alim iuf)
 447               (declare (ignore var-0 var-1 var-7 var-8))
 448               (setf s1r var-2)
 449               (setf s1i var-3)
 450               (setf s2r var-4)
 451               (setf s2i var-5)
 452               (setf nw var-6)
 453               (setf iuf var-9))
 454             (setf nz (f2cl-lib:int-add nz nw))
 455            label250
 456             (setf (f2cl-lib:fref yr-%data% (kk) ((1 n)) yr-%offset%)
 457                     (+ (- (* s1r cspnr) (* s1i cspni)) s2r))
 458             (setf (f2cl-lib:fref yi-%data% (kk) ((1 n)) yi-%offset%)
 459                     (+ (* cspnr s1i) (* cspni s1r) s2i))
 460             (setf kk (f2cl-lib:int-sub kk 1))
 461             (setf cspnr (- cspnr))
 462             (setf cspni (- cspni))
 463             (if (or (/= c2r 0.0) (/= c2i 0.0)) (go label255))
 464             (setf kdflg 1)
 465             (go label270)
 466            label255
 467             (if (= kdflg 2) (go label275))
 468             (setf kdflg 2)
 469             (go label270)
 470            label260
 471             (if (> rs1 0.0) (go label300))
 472             (setf s2r zeror)
 473             (setf s2i zeroi)
 474             (go label230)
 475            label270))
 476         (setf k n)
 477        label275
 478         (setf il (f2cl-lib:int-sub n k))
 479         (if (= il 0) (go end_label))
 480         (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
 481         (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
 482         (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
 483         (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
 484         (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
 485         (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 486         (setf fn
 487                 (coerce (the f2cl-lib:integer4 (f2cl-lib:int-add inu il))
 488                         'double-float))
 489         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 490                       ((> i il) nil)
 491           (tagbody
 492             (setf c2r s2r)
 493             (setf c2i s2i)
 494             (setf s2r (+ s1r (* (+ fn fnf) (- (* rzr c2r) (* rzi c2i)))))
 495             (setf s2i (+ s1i (* (+ fn fnf) (+ (* rzr c2i) (* rzi c2r)))))
 496             (setf s1r c2r)
 497             (setf s1i c2i)
 498             (setf fn (- fn 1.0))
 499             (setf c2r (* s2r csr))
 500             (setf c2i (* s2i csr))
 501             (setf ckr c2r)
 502             (setf cki c2i)
 503             (setf c1r (f2cl-lib:fref yr-%data% (kk) ((1 n)) yr-%offset%))
 504             (setf c1i (f2cl-lib:fref yi-%data% (kk) ((1 n)) yi-%offset%))
 505             (if (= kode 1) (go label280))
 506             (multiple-value-bind
 507                   (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
 508                 (zs1s2 zrr zri c1r c1i c2r c2i nw asc alim iuf)
 509               (declare (ignore var-0 var-1 var-7 var-8))
 510               (setf c1r var-2)
 511               (setf c1i var-3)
 512               (setf c2r var-4)
 513               (setf c2i var-5)
 514               (setf nw var-6)
 515               (setf iuf var-9))
 516             (setf nz (f2cl-lib:int-add nz nw))
 517            label280
 518             (setf (f2cl-lib:fref yr-%data% (kk) ((1 n)) yr-%offset%)
 519                     (+ (- (* c1r cspnr) (* c1i cspni)) c2r))
 520             (setf (f2cl-lib:fref yi-%data% (kk) ((1 n)) yi-%offset%)
 521                     (+ (* c1r cspni) (* c1i cspnr) c2i))
 522             (setf kk (f2cl-lib:int-sub kk 1))
 523             (setf cspnr (- cspnr))
 524             (setf cspni (- cspni))
 525             (if (>= iflag 3) (go label290))
 526             (setf c2r (abs ckr))
 527             (setf c2i (abs cki))
 528             (setf c2m (max c2r c2i))
 529             (if (<= c2m ascle) (go label290))
 530             (setf iflag (f2cl-lib:int-add iflag 1))
 531             (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 532             (setf s1r (* s1r csr))
 533             (setf s1i (* s1i csr))
 534             (setf s2r ckr)
 535             (setf s2i cki)
 536             (setf s1r (* s1r (f2cl-lib:fref cssr (iflag) ((1 3)))))
 537             (setf s1i (* s1i (f2cl-lib:fref cssr (iflag) ((1 3)))))
 538             (setf s2r (* s2r (f2cl-lib:fref cssr (iflag) ((1 3)))))
 539             (setf s2i (* s2i (f2cl-lib:fref cssr (iflag) ((1 3)))))
 540             (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
 541            label290))
 542         (go end_label)
 543        label300
 544         (setf nz -1)
 545         (go end_label)
 546        end_label
 547         (return (values nil nil nil nil nil nil nil nil nz nil nil nil))))))
 548
 549 (in-package #:cl-user)
 550 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 551 (eval-when (:load-toplevel :compile-toplevel :execute)
 552   (setf (gethash 'fortran-to-lisp::zunk1 fortran-to-lisp::*f2cl-function-info*)
 553           (fortran-to-lisp::make-f2cl-finfo
 554            :arg-types '((double-float) (double-float) (double-float)
 555                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 556                         (fortran-to-lisp::integer4) (array double-float (*))
 557                         (array double-float (*)) (fortran-to-lisp::integer4)
 558                         (double-float) (double-float) (double-float))
 559            :return-values '(nil nil nil nil nil nil nil nil fortran-to-lisp::nz
 560                             nil nil nil)
 561            :calls '(fortran-to-lisp::zs1s2 fortran-to-lisp::zuchk
 562                     fortran-to-lisp::zabs fortran-to-lisp::zunik
 563                     fortran-to-lisp::d1mach))))
 564