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) (zeroi 0.0)) 21 (declare (type (double-float) zeror zeroi)) 22 (defun zbinu (zr zi fnu kode n cyr cyi nz rl fnul tol elim alim) 23 (declare (type (simple-array double-float (*)) cyi cyr) 24 (type (f2cl-lib:integer4) nz n kode) 25 (type (double-float) alim elim tol fnul rl fnu zi zr)) 26 (prog ((cwr (make-array 2 :element-type 'double-float)) 27 (cwi (make-array 2 :element-type 'double-float)) (i 0) (inw 0) 28 (nlast 0) (nn 0) (nui 0) (nw 0) (az 0.0) (dfnu 0.0)) 29 (declare (type (simple-array double-float (2)) cwr cwi) 30 (type (double-float) dfnu az) 31 (type (f2cl-lib:integer4) nw nui nn nlast inw i)) 32 (setf nz 0) 33 (setf az (coerce (realpart (zabs zr zi)) 'double-float)) 34 (setf nn n) 35 (setf dfnu (+ fnu (f2cl-lib:int-sub n 1))) 36 (if (<= az 2.0) (go label10)) 37 (if (> (* az az 0.25) (+ dfnu 1.0)) (go label20)) 38 label10 39 (multiple-value-bind 40 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 41 var-10) 42 (zseri zr zi fnu kode nn cyr cyi nw tol elim alim) 43 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 44 var-10)) 45 (setf nw var-7)) 46 (setf inw (abs nw)) 47 (setf nz (f2cl-lib:int-add nz inw)) 48 (setf nn (f2cl-lib:int-sub nn inw)) 49 (if (= nn 0) (go end_label)) 50 (if (>= nw 0) (go label120)) 51 (setf dfnu (+ fnu (f2cl-lib:int-sub nn 1))) 52 label20 53 (if (< az rl) (go label40)) 54 (if (<= dfnu 1.0) (go label30)) 55 (if (< (+ az az) (* dfnu dfnu)) (go label50)) 56 label30 57 (multiple-value-bind 58 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10 59 var-11) 60 (zasyi zr zi fnu kode nn cyr cyi nw rl tol elim alim) 61 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 62 var-10 var-11)) 63 (setf nw var-7)) 64 (if (< nw 0) (go label130)) 65 (go label120) 66 label40 67 (if (<= dfnu 1.0) (go label70)) 68 label50 69 (multiple-value-bind 70 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10 71 var-11) 72 (zuoik zr zi fnu kode 1 nn cyr cyi nw tol elim alim) 73 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9 74 var-10 var-11)) 75 (setf nw var-8)) 76 (if (< nw 0) (go label130)) 77 (setf nz (f2cl-lib:int-add nz nw)) 78 (setf nn (f2cl-lib:int-sub nn nw)) 79 (if (= nn 0) (go end_label)) 80 (setf dfnu (+ fnu (f2cl-lib:int-sub nn 1))) 81 (if (> dfnu fnul) (go label110)) 82 (if (> az fnul) (go label110)) 83 label60 84 (if (> az rl) (go label80)) 85 label70 86 (multiple-value-bind 87 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) 88 (zmlri zr zi fnu kode nn cyr cyi nw tol) 89 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8)) 90 (setf nw var-7)) 91 (if (< nw 0) (go label130)) 92 (go label120) 93 label80 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 var-10 96 var-11) 97 (zuoik zr zi fnu kode 2 2 cwr cwi nw tol elim alim) 98 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9 99 var-10 var-11)) 100 (setf nw var-8)) 101 (if (>= nw 0) (go label100)) 102 (setf nz nn) 103 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 104 ((> i nn) nil) 105 (tagbody 106 (setf (f2cl-lib:fref cyr (i) ((1 n))) zeror) 107 (setf (f2cl-lib:fref cyi (i) ((1 n))) zeroi) 108 label90)) 109 (go end_label) 110 label100 111 (if (> nw 0) (go label130)) 112 (multiple-value-bind 113 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10 114 var-11 var-12) 115 (zwrsk zr zi fnu kode nn cyr cyi nw cwr cwi tol elim alim) 116 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 117 var-10 var-11 var-12)) 118 (setf nw var-7)) 119 (if (< nw 0) (go label130)) 120 (go label120) 121 label110 122 (setf nui (f2cl-lib:int (+ (- fnul dfnu) 1))) 123 (setf nui (max (the f2cl-lib:integer4 nui) (the f2cl-lib:integer4 0))) 124 (multiple-value-bind 125 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10 126 var-11 var-12 var-13) 127 (zbuni zr zi fnu kode nn cyr cyi nw nui nlast fnul tol elim alim) 128 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-10 129 var-11 var-12 var-13)) 130 (setf nw var-7) 131 (setf nlast var-9)) 132 (if (< nw 0) (go label130)) 133 (setf nz (f2cl-lib:int-add nz nw)) 134 (if (= nlast 0) (go label120)) 135 (setf nn nlast) 136 (go label60) 137 label120 138 (go end_label) 139 label130 140 (setf nz -1) 141 (if (= nw -2) (setf nz -2)) 142 (go end_label) 143 end_label 144 (return (values nil nil nil nil nil nil nil nz nil nil nil nil nil))))) 145 146(in-package #-gcl #:cl-user #+gcl "CL-USER") 147#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 148(eval-when (:load-toplevel :compile-toplevel :execute) 149 (setf (gethash 'fortran-to-lisp::zbinu fortran-to-lisp::*f2cl-function-info*) 150 (fortran-to-lisp::make-f2cl-finfo 151 :arg-types '((double-float) (double-float) (double-float) 152 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 153 (simple-array double-float (*)) 154 (simple-array double-float (*)) 155 (fortran-to-lisp::integer4) (double-float) 156 (double-float) (double-float) (double-float) 157 (double-float)) 158 :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz nil 159 nil nil nil nil) 160 :calls '(fortran-to-lisp::zbuni fortran-to-lisp::zwrsk 161 fortran-to-lisp::zmlri fortran-to-lisp::zuoik 162 fortran-to-lisp::zasyi fortran-to-lisp::zseri 163 fortran-to-lisp::zabs)))) 164 165