;;; Compiled by f2cl version 2.0 beta Date: 2007/05/04 17:29:50 
;;; Using Lisp CMU Common Lisp Snapshot 2007-05 (19D)
;;; 
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
;;;           (:array-slicing nil) (:declare-common nil)
;;;           (:float-format double-float))

(in-package :slatec)


(let ((zeror 0.0) (zeroi 0.0) (coner 1.0) (conei 0.0))
  (declare (type (double-float) conei coner zeroi zeror))
  (defun zmlri (zr zi fnu kode n yr yi nz tol)
    (declare (type (simple-array double-float (*)) yi yr)
             (type (f2cl-lib:integer4) nz n kode)
             (type (double-float) tol fnu zi zr))
    (prog ((i 0) (iaz 0) (idum 0) (ifnu 0) (inu 0) (itime 0) (k 0) (kk 0)
           (km 0) (m 0) (ack 0.0) (ak 0.0) (ap 0.0) (at 0.0) (az 0.0) (bk 0.0)
           (cki 0.0) (ckr 0.0) (cnormi 0.0) (cnormr 0.0) (fkap 0.0) (fkk 0.0)
           (flam 0.0) (fnf 0.0) (pti 0.0) (ptr 0.0) (p1i 0.0) (p1r 0.0)
           (p2i 0.0) (p2r 0.0) (raz 0.0) (rho 0.0) (rho2 0.0) (rzi 0.0)
           (rzr 0.0) (scle 0.0) (sti 0.0) (str 0.0) (sumi 0.0) (sumr 0.0)
           (tfnf 0.0) (tst 0.0))
      (declare (type (double-float) tst tfnf sumr sumi str sti scle rzr rzi
                                    rho2 rho raz p2r p2i p1r p1i ptr pti fnf
                                    flam fkk fkap cnormr cnormi ckr cki bk az
                                    at ap ak ack)
               (type (f2cl-lib:integer4) m km kk k itime inu ifnu idum iaz i))
      (setf scle (/ (f2cl-lib:d1mach 1) tol))
      (setf nz 0)
      (setf az (coerce (realpart (zabs zr zi)) 'double-float))
      (setf iaz (f2cl-lib:int az))
      (setf ifnu (f2cl-lib:int fnu))
      (setf inu (f2cl-lib:int-sub (f2cl-lib:int-add ifnu n) 1))
      (setf at (+ iaz 1.0))
      (setf raz (/ 1.0 az))
      (setf str (* zr raz))
      (setf sti (* (- zi) raz))
      (setf ckr (* str at raz))
      (setf cki (* sti at raz))
      (setf rzr (* (+ str str) raz))
      (setf rzi (* (+ sti sti) raz))
      (setf p1r zeror)
      (setf p1i zeroi)
      (setf p2r coner)
      (setf p2i conei)
      (setf ack (* (+ at 1.0) raz))
      (setf rho (+ ack (f2cl-lib:fsqrt (- (* ack ack) 1.0))))
      (setf rho2 (* rho rho))
      (setf tst (/ (+ rho2 rho2) (* (- rho2 1.0) (- rho 1.0))))
      (setf tst (/ tst tol))
      (setf ak at)
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i 80) nil)
        (tagbody
          (setf ptr p2r)
          (setf pti p2i)
          (setf p2r (- p1r (- (* ckr ptr) (* cki pti))))
          (setf p2i (- p1i (+ (* cki ptr) (* ckr pti))))
          (setf p1r ptr)
          (setf p1i pti)
          (setf ckr (+ ckr rzr))
          (setf cki (+ cki rzi))
          (setf ap (coerce (realpart (zabs p2r p2i)) 'double-float))
          (if (> ap (* tst ak ak)) (go label20))
          (setf ak (+ ak 1.0))
         label10))
      (go label110)
     label20
      (setf i (f2cl-lib:int-add i 1))
      (setf k 0)
      (if (< inu iaz) (go label40))
      (setf p1r zeror)
      (setf p1i zeroi)
      (setf p2r coner)
      (setf p2i conei)
      (setf at (+ inu 1.0))
      (setf str (* zr raz))
      (setf sti (* (- zi) raz))
      (setf ckr (* str at raz))
      (setf cki (* sti at raz))
      (setf ack (* at raz))
      (setf tst (f2cl-lib:fsqrt (/ ack tol)))
      (setf itime 1)
      (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
                    ((> k 80) nil)
        (tagbody
          (setf ptr p2r)
          (setf pti p2i)
          (setf p2r (- p1r (- (* ckr ptr) (* cki pti))))
          (setf p2i (- p1i (+ (* ckr pti) (* cki ptr))))
          (setf p1r ptr)
          (setf p1i pti)
          (setf ckr (+ ckr rzr))
          (setf cki (+ cki rzi))
          (setf ap (coerce (realpart (zabs p2r p2i)) 'double-float))
          (if (< ap tst) (go label30))
          (if (= itime 2) (go label40))
          (setf ack (coerce (realpart (zabs ckr cki)) 'double-float))
          (setf flam (+ ack (f2cl-lib:fsqrt (- (* ack ack) 1.0))))
          (setf fkap (coerce (realpart (/ ap (zabs p1r p1i))) 'double-float))
          (setf rho (min flam fkap))
          (setf tst (* tst (f2cl-lib:fsqrt (/ rho (- (* rho rho) 1.0)))))
          (setf itime 2)
         label30))
      (go label110)
     label40
      (setf k (f2cl-lib:int-add k 1))
      (setf kk
              (max (the f2cl-lib:integer4 (f2cl-lib:int-add i iaz))
                   (the f2cl-lib:integer4 (f2cl-lib:int-add k inu))))
      (setf fkk (coerce (the f2cl-lib:integer4 kk) 'double-float))
      (setf p1r zeror)
      (setf p1i zeroi)
      (setf p2r scle)
      (setf p2i zeroi)
      (setf fnf (- fnu ifnu))
      (setf tfnf (+ fnf fnf))
      (setf bk
              (-
               (multiple-value-bind (ret-val var-0 var-1)
                   (dgamln (+ fkk tfnf 1.0) idum)
                 (declare (ignore var-0))
                 (setf idum var-1)
                 ret-val)
               (multiple-value-bind (ret-val var-0 var-1)
                   (dgamln (+ fkk 1.0) idum)
                 (declare (ignore var-0))
                 (setf idum var-1)
                 ret-val)
               (multiple-value-bind (ret-val var-0 var-1)
                   (dgamln (+ tfnf 1.0) idum)
                 (declare (ignore var-0))
                 (setf idum var-1)
                 ret-val)))
      (setf bk (exp bk))
      (setf sumr zeror)
      (setf sumi zeroi)
      (setf km (f2cl-lib:int-sub kk inu))
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i km) nil)
        (tagbody
          (setf ptr p2r)
          (setf pti p2i)
          (setf p2r (+ p1r (* (+ fkk fnf) (- (* rzr ptr) (* rzi pti)))))
          (setf p2i (+ p1i (* (+ fkk fnf) (+ (* rzi ptr) (* rzr pti)))))
          (setf p1r ptr)
          (setf p1i pti)
          (setf ak (+ 1.0 (/ (- tfnf) (+ fkk tfnf))))
          (setf ack (* bk ak))
          (setf sumr (+ sumr (* (+ ack bk) p1r)))
          (setf sumi (+ sumi (* (+ ack bk) p1i)))
          (setf bk ack)
          (setf fkk (- fkk 1.0))
         label50))
      (setf (f2cl-lib:fref yr (n) ((1 n))) p2r)
      (setf (f2cl-lib:fref yi (n) ((1 n))) p2i)
      (if (= n 1) (go label70))
      (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
                    ((> i n) nil)
        (tagbody
          (setf ptr p2r)
          (setf pti p2i)
          (setf p2r (+ p1r (* (+ fkk fnf) (- (* rzr ptr) (* rzi pti)))))
          (setf p2i (+ p1i (* (+ fkk fnf) (+ (* rzi ptr) (* rzr pti)))))
          (setf p1r ptr)
          (setf p1i pti)
          (setf ak (+ 1.0 (/ (- tfnf) (+ fkk tfnf))))
          (setf ack (* bk ak))
          (setf sumr (+ sumr (* (+ ack bk) p1r)))
          (setf sumi (+ sumi (* (+ ack bk) p1i)))
          (setf bk ack)
          (setf fkk (- fkk 1.0))
          (setf m (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1))
          (setf (f2cl-lib:fref yr (m) ((1 n))) p2r)
          (setf (f2cl-lib:fref yi (m) ((1 n))) p2i)
         label60))
     label70
      (if (<= ifnu 0) (go label90))
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i ifnu) nil)
        (tagbody
          (setf ptr p2r)
          (setf pti p2i)
          (setf p2r (+ p1r (* (+ fkk fnf) (- (* rzr ptr) (* rzi pti)))))
          (setf p2i (+ p1i (* (+ fkk fnf) (+ (* rzr pti) (* rzi ptr)))))
          (setf p1r ptr)
          (setf p1i pti)
          (setf ak (+ 1.0 (/ (- tfnf) (+ fkk tfnf))))
          (setf ack (* bk ak))
          (setf sumr (+ sumr (* (+ ack bk) p1r)))
          (setf sumi (+ sumi (* (+ ack bk) p1i)))
          (setf bk ack)
          (setf fkk (- fkk 1.0))
         label80))
     label90
      (setf ptr zr)
      (setf pti zi)
      (if (= kode 2) (setf ptr zeror))
      (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
          (zlog rzr rzi str sti idum)
        (declare (ignore var-0 var-1))
        (setf str var-2)
        (setf sti var-3)
        (setf idum var-4))
      (setf p1r (+ (* (- fnf) str) ptr))
      (setf p1i (+ (* (- fnf) sti) pti))
      (setf ap
              (multiple-value-bind (ret-val var-0 var-1)
                  (dgamln (+ 1.0 fnf) idum)
                (declare (ignore var-0))
                (setf idum var-1)
                ret-val))
      (setf ptr (- p1r ap))
      (setf pti p1i)
      (setf p2r (+ p2r sumr))
      (setf p2i (+ p2i sumi))
      (setf ap (coerce (realpart (zabs p2r p2i)) 'double-float))
      (setf p1r (/ 1.0 ap))
      (multiple-value-bind (var-0 var-1 var-2 var-3)
          (zexp ptr pti str sti)
        (declare (ignore var-0 var-1))
        (setf str var-2)
        (setf sti var-3))
      (setf ckr (* str p1r))
      (setf cki (* sti p1r))
      (setf ptr (* p2r p1r))
      (setf pti (* (- p2i) p1r))
      (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
          (zmlt ckr cki ptr pti cnormr cnormi)
        (declare (ignore var-0 var-1 var-2 var-3))
        (setf cnormr var-4)
        (setf cnormi var-5))
      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                    ((> i n) nil)
        (tagbody
          (setf str
                  (- (* (f2cl-lib:fref yr (i) ((1 n))) cnormr)
                     (* (f2cl-lib:fref yi (i) ((1 n))) cnormi)))
          (setf (f2cl-lib:fref yi (i) ((1 n)))
                  (+ (* (f2cl-lib:fref yr (i) ((1 n))) cnormi)
                     (* (f2cl-lib:fref yi (i) ((1 n))) cnormr)))
          (setf (f2cl-lib:fref yr (i) ((1 n))) str)
         label100))
      (go end_label)
     label110
      (setf nz -2)
      (go end_label)
     end_label
      (return (values nil nil nil nil nil nil nil nz nil)))))

(in-package #-gcl #:cl-user #+gcl "CL-USER")
#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
(eval-when (:load-toplevel :compile-toplevel :execute)
  (setf (gethash 'fortran-to-lisp::zmlri fortran-to-lisp::*f2cl-function-info*)
          (fortran-to-lisp::make-f2cl-finfo
           :arg-types '((double-float) (double-float) (double-float)
                        (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
                        (simple-array double-float (*))
                        (simple-array double-float (*))
                        (fortran-to-lisp::integer4) (double-float))
           :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz
                            nil)
           :calls '(fortran-to-lisp::zmlt fortran-to-lisp::zexp
                    fortran-to-lisp::zlog fortran-to-lisp::dgamln
                    fortran-to-lisp::zabs fortran-to-lisp::d1mach))))