From: Raymond T. <rt...@us...> - 2002-04-26 12:42:43
|
Update of /cvsroot/maxima/maxima/src/numerical/slatec In directory usw-pr-cvs1:/tmp/cvs-serv2044 Added Files: zseri.lisp Log Message: Initial revision --- NEW FILE: zseri.lisp --- ;;; Compiled by f2cl version 2.0 beta on 2002/04/25 at 13:19:29 ;;; ;;; 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 zseri (zr zi fnu kode n yr yi nz tol elim alim) (declare (type (simple-array double-float (*)) yr yi) (type f2cl-lib:integer4 kode n nz) (type double-float zr zi fnu tol elim alim)) (f2cl-lib:with-array-data (yi-%data% yi-%offset% yi) (declare (type f2cl-lib:integer4 yi-%offset%) (type (simple-array double-float (*)) yi-%data%) (ignorable yi-%offset% yi-%data%)) (f2cl-lib:with-array-data (yr-%data% yr-%offset% yr) (declare (type f2cl-lib:integer4 yr-%offset%) (type (simple-array double-float (*)) yr-%data%) (ignorable yr-%offset% yr-%data%)) (prog ((wr (make-array 2 :element-type 'double-float)) (wi (make-array 2 :element-type 'double-float)) (i 0) (ib 0) (idum 0) (iflag 0) (il 0) (k 0) (l 0) (m 0) (nn 0) (nw 0) (aa 0.0) (acz 0.0) (ak 0.0) (ak1i 0.0) (ak1r 0.0) (arm 0.0) (ascle 0.0) (atol 0.0) (az 0.0) (cki 0.0) (ckr 0.0) (coefi 0.0) (coefr 0.0) (crscr 0.0) (czi 0.0) (czr 0.0) (dfnu 0.0) (fnup 0.0) (hzi 0.0) (hzr 0.0) (raz 0.0) (rs 0.0) (rtr1 0.0) (rzi 0.0) (rzr 0.0) (s 0.0) (ss 0.0) (sti 0.0) (str 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0)) (declare (type (simple-array double-float (2)) wr wi) (type double-float s2r s2i s1r s1i str sti ss s rzr rzi rtr1 rs raz hzr hzi fnup dfnu czr czi crscr coefr coefi ckr cki az atol ascle arm ak1r ak1i ak acz aa) (type f2cl-lib:integer4 nw nn m l k il iflag idum ib i)) (setf nz 0) (setf az (multiple-value-bind (ret-val var-0 var-1) (zabs zr zi) (declare (ignore)) (when var-0 (setf zr var-0)) (when var-1 (setf zi var-1)) ret-val)) (if (= az 0.0) (go label160)) (setf arm (* 1000.0 (f2cl-lib:d1mach 1))) (setf rtr1 (f2cl-lib:fsqrt arm)) (setf crscr 1.0) (setf iflag 0) (if (< az arm) (go label150)) (setf hzr (* 0.5 zr)) (setf hzi (* 0.5 zi)) (setf czr zeror) (setf czi zeroi) (if (<= az rtr1) (go label10)) (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) (zmlt hzr hzi hzr hzi czr czi) (declare (ignore var-0 var-1 var-2 var-3)) (when var-4 (setf czr var-4)) (when var-5 (setf czi var-5))) label10 (setf acz (multiple-value-bind (ret-val var-0 var-1) (zabs czr czi) (declare (ignore)) (when var-0 (setf czr var-0)) (when var-1 (setf czi var-1)) ret-val)) (setf nn n) (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) (zlog hzr hzi ckr cki idum) (declare (ignore)) (when var-0 (setf hzr var-0)) (when var-1 (setf hzi var-1)) (when var-2 (setf ckr var-2)) (when var-3 (setf cki var-3)) (when var-4 (setf idum var-4))) label20 (setf dfnu (+ fnu (f2cl-lib:int-sub nn 1))) (setf fnup (+ dfnu 1.0)) (setf ak1r (* ckr dfnu)) (setf ak1i (* cki dfnu)) (setf ak (multiple-value-bind (ret-val var-0 var-1) (dgamln fnup idum) (declare (ignore)) (when var-0 (setf fnup var-0)) (when var-1 (setf idum var-1)) ret-val)) (setf ak1r (- ak1r ak)) (if (= kode 2) (setf ak1r (- ak1r zr))) (if (> ak1r (- elim)) (go label40)) label30 (setf nz (f2cl-lib:int-add nz 1)) (f2cl-lib:fset (f2cl-lib:fref yr-%data% (nn) ((1 n)) yr-%offset%) zeror) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (nn) ((1 n)) yi-%offset%) zeroi) (if (> acz dfnu) (go label190)) (setf nn (f2cl-lib:int-sub nn 1)) (if (= nn 0) (go end_label)) (go label20) label40 (if (> ak1r (- alim)) (go label50)) (setf iflag 1) (setf ss (/ 1.0 tol)) (setf crscr tol) (setf ascle (* arm ss)) label50 (setf aa (exp ak1r)) (if (= iflag 1) (setf aa (* aa ss))) (setf coefr (* aa (cos ak1i))) (setf coefi (* aa (sin ak1i))) (setf atol (/ (* tol acz) fnup)) (setf il (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 nn))) (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) ((> i il) nil) (tagbody (setf dfnu (+ fnu (f2cl-lib:int-sub nn i))) (setf fnup (+ dfnu 1.0)) (setf s1r coner) (setf s1i conei) (if (< acz (* tol fnup)) (go label70)) (setf ak1r coner) (setf ak1i conei) (setf ak (+ fnup 2.0)) (setf s fnup) (setf aa 2.0) label60 (setf rs (/ 1.0 s)) (setf str (- (* ak1r czr) (* ak1i czi))) (setf sti (+ (* ak1r czi) (* ak1i czr))) (setf ak1r (* str rs)) (setf ak1i (* sti rs)) (setf s1r (+ s1r ak1r)) (setf s1i (+ s1i ak1i)) (setf s (+ s ak)) (setf ak (+ ak 2.0)) (setf aa (* aa acz rs)) (if (> aa atol) (go label60)) label70 (setf s2r (- (* s1r coefr) (* s1i coefi))) (setf s2i (+ (* s1r coefi) (* s1i coefr))) (f2cl-lib:fset (f2cl-lib:fref wr (i) ((1 2))) s2r) (f2cl-lib:fset (f2cl-lib:fref wi (i) ((1 2))) s2i) (if (= iflag 0) (go label80)) (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) (zuchk s2r s2i nw ascle tol) (declare (ignore)) (when var-0 (setf s2r var-0)) (when var-1 (setf s2i var-1)) (when var-2 (setf nw var-2)) (when var-3 (setf ascle var-3)) (when var-4 (setf tol var-4))) (if (/= nw 0) (go label30)) label80 (setf m (f2cl-lib:int-add (f2cl-lib:int-sub nn i) 1)) (f2cl-lib:fset (f2cl-lib:fref yr-%data% (m) ((1 n)) yr-%offset%) (* s2r crscr)) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (m) ((1 n)) yi-%offset%) (* s2i crscr)) (if (= i il) (go label90)) (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) (zdiv coefr coefi hzr hzi str sti) (declare (ignore)) (when var-0 (setf coefr var-0)) (when var-1 (setf coefi var-1)) (when var-2 (setf hzr var-2)) (when var-3 (setf hzi var-3)) (when var-4 (setf str var-4)) (when var-5 (setf sti var-5))) (setf coefr (* str dfnu)) (setf coefi (* sti dfnu)) label90)) (if (<= nn 2) (go end_label)) (setf k (f2cl-lib:int-sub nn 2)) (setf ak (coerce (the f2cl-lib:integer4 k) 'double-float)) (setf raz (/ 1.0 az)) (setf str (* zr raz)) (setf sti (* (- zi) raz)) (setf rzr (* (+ str str) raz)) (setf rzi (* (+ sti sti) raz)) (if (= iflag 1) (go label120)) (setf ib 3) label100 (f2cl-lib:fdo (i ib (f2cl-lib:int-add i 1)) ((> i nn) nil) (tagbody (f2cl-lib:fset (f2cl-lib:fref yr-%data% (k) ((1 n)) yr-%offset%) (+ (* (+ ak fnu) (- (* rzr (f2cl-lib:fref yr-%data% ((f2cl-lib:int-add k 1)) ((1 n)) yr-%offset%)) (* rzi (f2cl-lib:fref yi-%data% ((f2cl-lib:int-add k 1)) ((1 n)) yi-%offset%)))) (f2cl-lib:fref yr-%data% ((f2cl-lib:int-add k 2)) ((1 n)) yr-%offset%))) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (k) ((1 n)) yi-%offset%) (+ (* (+ ak fnu) (+ (* rzr (f2cl-lib:fref yi-%data% ((f2cl-lib:int-add k 1)) ((1 n)) yi-%offset%)) (* rzi (f2cl-lib:fref yr-%data% ((f2cl-lib:int-add k 1)) ((1 n)) yr-%offset%)))) (f2cl-lib:fref yi-%data% ((f2cl-lib:int-add k 2)) ((1 n)) yi-%offset%))) (setf ak (- ak 1.0)) (setf k (f2cl-lib:int-sub k 1)) label110)) (go end_label) label120 (setf s1r (f2cl-lib:fref wr (1) ((1 2)))) (setf s1i (f2cl-lib:fref wi (1) ((1 2)))) (setf s2r (f2cl-lib:fref wr (2) ((1 2)))) (setf s2i (f2cl-lib:fref wi (2) ((1 2)))) (f2cl-lib:fdo (l 3 (f2cl-lib:int-add l 1)) ((> l nn) nil) (tagbody (setf ckr s2r) (setf cki s2i) (setf s2r (+ s1r (* (+ ak fnu) (- (* rzr ckr) (* rzi cki))))) (setf s2i (+ s1i (* (+ ak fnu) (+ (* rzr cki) (* rzi ckr))))) (setf s1r ckr) (setf s1i cki) (setf ckr (* s2r crscr)) (setf cki (* s2i crscr)) (f2cl-lib:fset (f2cl-lib:fref yr-%data% (k) ((1 n)) yr-%offset%) ckr) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (k) ((1 n)) yi-%offset%) cki) (setf ak (- ak 1.0)) (setf k (f2cl-lib:int-sub k 1)) (if (> (multiple-value-bind (ret-val var-0 var-1) (zabs ckr cki) (declare (ignore)) (when var-0 (setf ckr var-0)) (when var-1 (setf cki var-1)) ret-val) ascle) (go label140)) label130)) (go end_label) label140 (setf ib (f2cl-lib:int-add l 1)) (if (> ib nn) (go end_label)) (go label100) label150 (setf nz n) (if (= fnu 0.0) (setf nz (f2cl-lib:int-sub nz 1))) label160 (f2cl-lib:fset (f2cl-lib:fref yr-%data% (1) ((1 n)) yr-%offset%) zeror) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (1) ((1 n)) yi-%offset%) zeroi) (if (/= fnu 0.0) (go label170)) (f2cl-lib:fset (f2cl-lib:fref yr-%data% (1) ((1 n)) yr-%offset%) coner) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (1) ((1 n)) yi-%offset%) conei) label170 (if (= n 1) (go end_label)) (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) ((> i n) nil) (tagbody (f2cl-lib:fset (f2cl-lib:fref yr-%data% (i) ((1 n)) yr-%offset%) zeror) (f2cl-lib:fset (f2cl-lib:fref yi-%data% (i) ((1 n)) yi-%offset%) zeroi) label180)) (go end_label) label190 (setf nz (f2cl-lib:int-sub nz)) (go end_label) end_label (return (values zr zi nil nil nil nil nil nz tol nil nil))))))) |