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 ((nulim 21 (make-array 2 22 :element-type 'f2cl-lib:integer4 23 :initial-contents '(35 70)))) 24 (declare (type (simple-array f2cl-lib:integer4 (2)) nulim)) 25 (defun dbesk (x fnu kode n y nz) 26 (declare (type (simple-array double-float (*)) y) 27 (type (f2cl-lib:integer4) nz n kode) 28 (type (double-float) fnu x)) 29 (prog ((w (make-array 2 :element-type 'double-float)) (cn 0.0) (dnu 0.0) 30 (elim 0.0) (etx 0.0) (flgik 0.0) (fn 0.0) (fnn 0.0) (gln 0.0) 31 (gnu 0.0) (rtz 0.0) (s 0.0) (s1 0.0) (s2 0.0) (t$ 0.0) (tm 0.0) 32 (trx 0.0) (xlim 0.0) (zn 0.0) (i 0) (j 0) (k 0) (mz 0) (nb 0) (nd 0) 33 (nn 0) (nud 0)) 34 (declare (type (f2cl-lib:integer4) nud nn nd nb mz k j i) 35 (type (simple-array double-float (2)) w) 36 (type (double-float) zn xlim trx tm t$ s2 s1 s rtz gnu gln fnn 37 fn flgik etx elim dnu cn)) 38 (setf nn (f2cl-lib:int-sub (f2cl-lib:i1mach 15))) 39 (setf elim (* 2.303 (- (* nn (f2cl-lib:d1mach 5)) 3.0))) 40 (setf xlim (* (f2cl-lib:d1mach 1) 1000.0)) 41 (if (or (< kode 1) (> kode 2)) (go label280)) 42 (if (< fnu 0.0) (go label290)) 43 (if (<= x 0.0) (go label300)) 44 (if (< x xlim) (go label320)) 45 (if (< n 1) (go label310)) 46 (setf etx 47 (coerce (the f2cl-lib:integer4 (f2cl-lib:int-sub kode 1)) 48 'double-float)) 49 (setf nd n) 50 (setf nz 0) 51 (setf nud (f2cl-lib:int fnu)) 52 (setf dnu (- fnu nud)) 53 (setf gnu fnu) 54 (setf nn (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 nd))) 55 (setf fn (- (+ fnu n) 1)) 56 (setf fnn fn) 57 (if (< fn 2.0) (go label150)) 58 (setf zn (/ x fn)) 59 (if (= zn 0.0) (go label320)) 60 (setf rtz (f2cl-lib:fsqrt (+ 1.0 (* zn zn)))) 61 (setf gln (f2cl-lib:flog (/ (+ 1.0 rtz) zn))) 62 (setf t$ (+ (* rtz (- 1.0 etx)) (/ etx (+ zn rtz)))) 63 (setf cn (* (- fn) (- t$ gln))) 64 (if (> cn elim) (go label320)) 65 (if (< nud (f2cl-lib:fref nulim (nn) ((1 2)))) (go label30)) 66 (if (= nn 1) (go label20)) 67 label10 68 (setf fn gnu) 69 (setf zn (/ x fn)) 70 (setf rtz (f2cl-lib:fsqrt (+ 1.0 (* zn zn)))) 71 (setf gln (f2cl-lib:flog (/ (+ 1.0 rtz) zn))) 72 (setf t$ (+ (* rtz (- 1.0 etx)) (/ etx (+ zn rtz)))) 73 (setf cn (* (- fn) (- t$ gln))) 74 label20 75 (if (< cn (- elim)) (go label230)) 76 (setf flgik -1.0) 77 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) 78 (dasyik x gnu kode flgik rtz cn nn y) 79 (declare (ignore var-0 var-1 var-2 var-3 var-6 var-7)) 80 (setf rtz var-4) 81 (setf cn var-5)) 82 (if (= nn 1) (go label240)) 83 (setf trx (/ 2.0 x)) 84 (setf tm (/ (+ gnu gnu 2.0) x)) 85 (go label130) 86 label30 87 (if (= kode 2) (go label40)) 88 (if (> x elim) (go label230)) 89 label40 90 (if (/= dnu 0.0) (go label80)) 91 (if (= kode 2) (go label50)) 92 (setf s1 (dbesk0 x)) 93 (go label60) 94 label50 95 (setf s1 (dbsk0e x)) 96 label60 97 (if (and (= nud 0) (= nd 1)) (go label120)) 98 (if (= kode 2) (go label70)) 99 (setf s2 (dbesk1 x)) 100 (go label90) 101 label70 102 (setf s2 (dbsk1e x)) 103 (go label90) 104 label80 105 (setf nb 2) 106 (if (and (= nud 0) (= nd 1)) (setf nb 1)) 107 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) 108 (dbsknu x dnu kode nb w nz) 109 (declare (ignore var-0 var-1 var-2 var-3 var-4)) 110 (setf nz var-5)) 111 (setf s1 (f2cl-lib:fref w (1) ((1 2)))) 112 (if (= nb 1) (go label120)) 113 (setf s2 (f2cl-lib:fref w (2) ((1 2)))) 114 label90 115 (setf trx (/ 2.0 x)) 116 (setf tm (/ (+ dnu dnu 2.0) x)) 117 (if (= nd 1) (setf nud (f2cl-lib:int-sub nud 1))) 118 (if (> nud 0) (go label100)) 119 (if (> nd 1) (go label120)) 120 (setf s1 s2) 121 (go label120) 122 label100 123 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 124 ((> i nud) nil) 125 (tagbody 126 (setf s s2) 127 (setf s2 (+ (* tm s2) s1)) 128 (setf s1 s) 129 (setf tm (+ tm trx)) 130 label110)) 131 (if (= nd 1) (setf s1 s2)) 132 label120 133 (setf (f2cl-lib:fref y (1) ((1 *))) s1) 134 (if (= nd 1) (go label240)) 135 (setf (f2cl-lib:fref y (2) ((1 *))) s2) 136 label130 137 (if (= nd 2) (go label240)) 138 (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1)) 139 ((> i nd) nil) 140 (tagbody 141 (setf (f2cl-lib:fref y (i) ((1 *))) 142 (+ (* tm (f2cl-lib:fref y ((f2cl-lib:int-sub i 1)) ((1 *)))) 143 (f2cl-lib:fref y ((f2cl-lib:int-sub i 2)) ((1 *))))) 144 (setf tm (+ tm trx)) 145 label140)) 146 (go label240) 147 label150 148 (if (= kode 2) (go label160)) 149 (if (> x elim) (go label230)) 150 label160 151 (if (<= fn 1.0) (go label170)) 152 (if (> (* (- fn) (- (f2cl-lib:flog x) 0.693)) elim) (go label320)) 153 label170 154 (if (= dnu 0.0) (go label180)) 155 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) 156 (dbsknu x fnu kode nd y mz) 157 (declare (ignore var-0 var-1 var-2 var-3 var-4)) 158 (setf mz var-5)) 159 (go label240) 160 label180 161 (setf j nud) 162 (if (= j 1) (go label210)) 163 (setf j (f2cl-lib:int-add j 1)) 164 (if (= kode 2) (go label190)) 165 (setf (f2cl-lib:fref y (j) ((1 *))) (dbesk0 x)) 166 (go label200) 167 label190 168 (setf (f2cl-lib:fref y (j) ((1 *))) (dbsk0e x)) 169 label200 170 (if (= nd 1) (go label240)) 171 (setf j (f2cl-lib:int-add j 1)) 172 label210 173 (if (= kode 2) (go label220)) 174 (setf (f2cl-lib:fref y (j) ((1 *))) (dbesk1 x)) 175 (go label240) 176 label220 177 (setf (f2cl-lib:fref y (j) ((1 *))) (dbsk1e x)) 178 (go label240) 179 label230 180 (setf nud (f2cl-lib:int-add nud 1)) 181 (setf nd (f2cl-lib:int-sub nd 1)) 182 (if (= nd 0) (go label240)) 183 (setf nn (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 nd))) 184 (setf gnu (+ gnu 1.0)) 185 (if (< fnn 2.0) (go label230)) 186 (if (< nud (f2cl-lib:fref nulim (nn) ((1 2)))) (go label230)) 187 (go label10) 188 label240 189 (setf nz (f2cl-lib:int-sub n nd)) 190 (if (= nz 0) (go end_label)) 191 (if (= nd 0) (go label260)) 192 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 193 ((> i nd) nil) 194 (tagbody 195 (setf j (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) 196 (setf k (f2cl-lib:int-add (f2cl-lib:int-sub nd i) 1)) 197 (setf (f2cl-lib:fref y (j) ((1 *))) (f2cl-lib:fref y (k) ((1 *)))) 198 label250)) 199 label260 200 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 201 ((> i nz) nil) 202 (tagbody (setf (f2cl-lib:fref y (i) ((1 *))) 0.0) label270)) 203 (go end_label) 204 label280 205 (xermsg "SLATEC" "DBESK" "SCALING OPTION, KODE, NOT 1 OR 2" 2 1) 206 (go end_label) 207 label290 208 (xermsg "SLATEC" "DBESK" "ORDER, FNU, LESS THAN ZERO" 2 1) 209 (go end_label) 210 label300 211 (xermsg "SLATEC" "DBESK" "X LESS THAN OR EQUAL TO ZERO" 2 1) 212 (go end_label) 213 label310 214 (xermsg "SLATEC" "DBESK" "N LESS THAN ONE" 2 1) 215 (go end_label) 216 label320 217 (xermsg "SLATEC" "DBESK" "OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL" 6 218 1) 219 (go end_label) 220 end_label 221 (return (values nil nil nil nil nil nz))))) 222 223(in-package #-gcl #:cl-user #+gcl "CL-USER") 224#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 225(eval-when (:load-toplevel :compile-toplevel :execute) 226 (setf (gethash 'fortran-to-lisp::dbesk fortran-to-lisp::*f2cl-function-info*) 227 (fortran-to-lisp::make-f2cl-finfo 228 :arg-types '((double-float) (double-float) 229 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 230 (simple-array double-float (*)) 231 (fortran-to-lisp::integer4)) 232 :return-values '(nil nil nil nil nil fortran-to-lisp::nz) 233 :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dbsknu 234 fortran-to-lisp::dbsk1e fortran-to-lisp::dbesk1 235 fortran-to-lisp::dbsk0e fortran-to-lisp::dbesk0 236 fortran-to-lisp::dasyik fortran-to-lisp::d1mach 237 fortran-to-lisp::i1mach)))) 238 239