1;;; Compiled by f2cl version: 2;;; ("f2cl1.l,v 1.221 2010/05/26 19:25:52 rtoy Exp $" 3;;; "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $" 4;;; "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $" 5;;; "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $" 6;;; "f2cl5.l,v 1.204 2010/02/23 05:21:30 rtoy Exp $" 7;;; "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $" 8;;; "macros.l,v 1.114 2010/05/17 01:42:14 rtoy Exp $") 9 10;;; Using Lisp CMU Common Lisp CVS Head 2010-05-25 18:21:07 (20A 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 :colnew) 18 19 20(defun approx (i x zval a coef xi n z dmz k ncomp mmax m mstar mode dmval modm) 21 (declare (type (array f2cl-lib:integer4 (*)) m) 22 (type (array double-float (*)) a) 23 (type (array double-float (*)) dmval dmz z xi coef zval) 24 (type double-float x) 25 (type (f2cl-lib:integer4) modm mode mstar mmax ncomp k n i)) 26 (let () 27 (symbol-macrolet ((precis (aref (colout-part-0 *colout-common-block*) 0)) 28 (iout (aref (colout-part-1 *colout-common-block*) 0)) 29 (iprint (aref (colout-part-1 *colout-common-block*) 1))) 30 (f2cl-lib:with-multi-array-data 31 ((zval double-float zval-%data% zval-%offset%) 32 (coef double-float coef-%data% coef-%offset%) 33 (xi double-float xi-%data% xi-%offset%) 34 (z double-float z-%data% z-%offset%) 35 (dmz double-float dmz-%data% dmz-%offset%) 36 (dmval double-float dmval-%data% dmval-%offset%) 37 (a double-float a-%data% a-%offset%) 38 (m f2cl-lib:integer4 m-%data% m-%offset%)) 39 (prog ((fact 0.0) (lb 0) (ll 0) (zsum 0.0) (ind 0) (mj 0) (jcomp 0) 40 (idmz 0) (ir 0) (s 0.0) (iright 0) (l 0) (ileft 0) (j 0) (iz 0) 41 (dm (make-array 7 :element-type 'double-float)) 42 (bm (make-array 4 :element-type 'double-float))) 43 (declare (type (array double-float (4)) bm) 44 (type (array double-float (7)) dm) 45 (type (f2cl-lib:integer4) iz j ileft l iright ir idmz jcomp 46 mj ind ll lb) 47 (type double-float s zsum fact)) 48 (f2cl-lib:computed-goto (label10 label30 label80 label90) mode) 49 label10 50 (setf x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 51 (setf iz (f2cl-lib:int-mul (f2cl-lib:int-sub i 1) mstar)) 52 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 53 ((> j mstar) nil) 54 (tagbody 55 (setf iz (f2cl-lib:int-add iz 1)) 56 (setf (f2cl-lib:fref zval-%data% (j) ((1 1)) zval-%offset%) 57 (f2cl-lib:fref z-%data% (iz) ((1 1)) z-%offset%)) 58 label20)) 59 (go end_label) 60 label30 61 (if 62 (and 63 (>= x (- (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) precis)) 64 (<= x 65 (+ 66 (f2cl-lib:fref xi-%data% 67 ((f2cl-lib:int-add n 1)) 68 ((1 1)) 69 xi-%offset%) 70 precis))) 71 (go label40)) 72 (if (< iprint 1) 73 (f2cl-lib:fformat iout 74 (" ****** DOMAIN ERROR IN APPROX ******" "~%" 75 " X =" 1 (("~20,10,2,0,'*,,'DE")) " ALEFT =" 76 1 (("~20,10,2,0,'*,,'DE")) " ARIGHT =" 1 77 (("~20,10,2,0,'*,,'DE")) "~%") 78 x 79 (f2cl-lib:fref xi-%data% 80 (1) 81 ((1 1)) 82 xi-%offset%) 83 (f2cl-lib:fref xi-%data% 84 ((f2cl-lib:int-add n 1)) 85 ((1 1)) 86 xi-%offset%))) 87 (if (< x (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%)) 88 (setf x (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%))) 89 (if 90 (> x 91 (f2cl-lib:fref xi-%data% 92 ((f2cl-lib:int-add n 1)) 93 ((1 1)) 94 xi-%offset%)) 95 (setf x 96 (f2cl-lib:fref xi-%data% 97 ((f2cl-lib:int-add n 1)) 98 ((1 1)) 99 xi-%offset%))) 100 label40 101 (if (or (> i n) (< i 1)) 102 (setf i (the f2cl-lib:integer4 (truncate (+ n 1) 2)))) 103 (setf ileft i) 104 (if (< x (f2cl-lib:fref xi-%data% (ileft) ((1 1)) xi-%offset%)) 105 (go label60)) 106 (f2cl-lib:fdo (l ileft (f2cl-lib:int-add l 1)) 107 ((> l n) nil) 108 (tagbody 109 (setf i l) 110 (if 111 (< x 112 (f2cl-lib:fref xi-%data% 113 ((f2cl-lib:int-add l 1)) 114 ((1 1)) 115 xi-%offset%)) 116 (go label80)) 117 label50)) 118 (go label80) 119 label60 120 (setf iright (f2cl-lib:int-sub ileft 1)) 121 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 122 ((> l iright) nil) 123 (tagbody 124 (setf i (f2cl-lib:int-sub (f2cl-lib:int-add iright 1) l)) 125 (if (>= x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 126 (go label80)) 127 label70)) 128 label80 129 (setf s 130 (/ (- x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 131 (- 132 (f2cl-lib:fref xi-%data% 133 ((f2cl-lib:int-add i 1)) 134 ((1 1)) 135 xi-%offset%) 136 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)))) 137 (rkbas s coef k mmax a dm modm) 138 label90 139 (setf (f2cl-lib:fref bm (1) ((1 4))) 140 (- x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))) 141 (f2cl-lib:fdo (l 2 (f2cl-lib:int-add l 1)) 142 ((> l mmax) nil) 143 (tagbody 144 (setf (f2cl-lib:fref bm (l) ((1 4))) 145 (/ (f2cl-lib:fref bm (1) ((1 4))) (f2cl-lib:dfloat l))) 146 label95)) 147 label100 148 (setf ir 1) 149 (setf iz 150 (f2cl-lib:int-add 151 (f2cl-lib:int-mul (f2cl-lib:int-sub i 1) mstar) 152 1)) 153 (setf idmz (f2cl-lib:int-mul (f2cl-lib:int-sub i 1) k ncomp)) 154 (f2cl-lib:fdo (jcomp 1 (f2cl-lib:int-add jcomp 1)) 155 ((> jcomp ncomp) nil) 156 (tagbody 157 (setf mj (f2cl-lib:fref m-%data% (jcomp) ((1 1)) m-%offset%)) 158 (setf ir (f2cl-lib:int-add ir mj)) 159 (setf iz (f2cl-lib:int-add iz mj)) 160 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 161 ((> l mj) nil) 162 (tagbody 163 (setf ind (f2cl-lib:int-add idmz jcomp)) 164 (setf zsum 0.0) 165 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 166 ((> j k) nil) 167 (tagbody 168 (setf zsum 169 (+ zsum 170 (* 171 (f2cl-lib:fref a-%data% 172 (j l) 173 ((1 7) (1 1)) 174 a-%offset%) 175 (f2cl-lib:fref dmz-%data% 176 (ind) 177 ((1 1)) 178 dmz-%offset%)))) 179 label110 180 (setf ind (f2cl-lib:int-add ind ncomp)))) 181 (f2cl-lib:fdo (ll 1 (f2cl-lib:int-add ll 1)) 182 ((> ll l) nil) 183 (tagbody 184 (setf lb (f2cl-lib:int-sub (f2cl-lib:int-add l 1) ll)) 185 label120 186 (setf zsum 187 (+ (* zsum (f2cl-lib:fref bm (lb) ((1 4)))) 188 (f2cl-lib:fref z-%data% 189 ((f2cl-lib:int-sub iz ll)) 190 ((1 1)) 191 z-%offset%))))) 192 label130 193 (setf (f2cl-lib:fref zval-%data% 194 ((f2cl-lib:int-sub ir l)) 195 ((1 1)) 196 zval-%offset%) 197 zsum))) 198 label140)) 199 (if (= modm 0) (go end_label)) 200 (f2cl-lib:fdo (jcomp 1 (f2cl-lib:int-add jcomp 1)) 201 ((> jcomp ncomp) nil) 202 (tagbody 203 label150 204 (setf (f2cl-lib:fref dmval-%data% (jcomp) ((1 1)) dmval-%offset%) 205 0.0))) 206 (setf idmz (f2cl-lib:int-add idmz 1)) 207 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 208 ((> j k) nil) 209 (tagbody 210 (setf fact (f2cl-lib:fref dm (j) ((1 7)))) 211 (f2cl-lib:fdo (jcomp 1 (f2cl-lib:int-add jcomp 1)) 212 ((> jcomp ncomp) nil) 213 (tagbody 214 (setf (f2cl-lib:fref dmval-%data% 215 (jcomp) 216 ((1 1)) 217 dmval-%offset%) 218 (+ 219 (f2cl-lib:fref dmval-%data% 220 (jcomp) 221 ((1 1)) 222 dmval-%offset%) 223 (* fact 224 (f2cl-lib:fref dmz-%data% 225 (idmz) 226 ((1 1)) 227 dmz-%offset%)))) 228 (setf idmz (f2cl-lib:int-add idmz 1)) 229 label160)) 230 label170)) 231 (go end_label) 232 end_label 233 (return 234 (values i 235 x 236 nil 237 nil 238 nil 239 nil 240 nil 241 nil 242 nil 243 nil 244 nil 245 nil 246 nil 247 nil 248 nil 249 nil 250 nil))))))) 251 252(in-package #-gcl #:cl-user #+gcl "CL-USER") 253#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 254(eval-when (:load-toplevel :compile-toplevel :execute) 255 (setf (gethash 'fortran-to-lisp::approx 256 fortran-to-lisp::*f2cl-function-info*) 257 (fortran-to-lisp::make-f2cl-finfo 258 :arg-types '((fortran-to-lisp::integer4) double-float 259 (array double-float (1)) (array double-float (7)) 260 (array double-float (1)) (array double-float (1)) 261 (fortran-to-lisp::integer4) (array double-float (1)) 262 (array double-float (1)) (fortran-to-lisp::integer4) 263 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 264 (array fortran-to-lisp::integer4 (1)) 265 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 266 (array double-float (1)) (fortran-to-lisp::integer4)) 267 :return-values '(fortran-to-lisp::i fortran-to-lisp::x nil nil nil 268 nil nil nil nil nil nil nil nil nil nil nil nil) 269 :calls '(fortran-to-lisp::rkbas)))) 270 271