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(let ((cnsts1 21 (make-array 28 22 :element-type 'double-float 23 :initial-contents '(0.25 0.0625 0.072169 0.018342 0.019065 24 0.05819 0.0054658 0.005337 0.01889 25 0.027792 0.0016095 0.0014964 0.0075938 26 0.0057573 0.018342 0.004673 4.15e-4 27 0.001919 0.001468 0.006371 0.00461 28 1.342e-4 1.138e-4 4.889e-4 4.177e-4 29 0.001374 0.001654 0.002863))) 30 (cnsts2 31 (make-array 28 32 :element-type 'double-float 33 :initial-contents '(0.125 0.002604 0.008019 2.17e-5 7.453e-5 34 5.208e-4 9.689e-8 3.689e-7 3.1e-6 35 2.451e-5 2.691e-10 1.12e-9 1.076e-8 36 9.405e-8 1.033e-6 5.097e-13 2.29e-12 37 2.446e-11 2.331e-10 2.936e-9 3.593e-8 38 7.001e-16 3.363e-15 3.921e-14 4.028e-13 39 5.646e-12 7.531e-11 1.129e-9)))) 40 (declare (type (array double-float (28)) cnsts1 cnsts2)) 41 (defun consts (k rho coef) 42 (declare (type (array double-float (*)) coef) 43 (type (array double-float (*)) rho) 44 (type (f2cl-lib:integer4) k)) 45 (let ((colord-m 46 (make-array 20 47 :element-type 'f2cl-lib:integer4 48 :displaced-to (colord-part-0 *colord-common-block*) 49 :displaced-index-offset 5)) 50 (colbas-b 51 (make-array 28 52 :element-type 'double-float 53 :displaced-to (colbas-part-0 *colbas-common-block*) 54 :displaced-index-offset 0)) 55 (colbas-acol 56 (make-array 196 57 :element-type 'double-float 58 :displaced-to (colbas-part-0 *colbas-common-block*) 59 :displaced-index-offset 28)) 60 (colbas-asave 61 (make-array 112 62 :element-type 'double-float 63 :displaced-to (colbas-part-0 *colbas-common-block*) 64 :displaced-index-offset 224)) 65 (colest-wgtmsh 66 (make-array 40 67 :element-type 'double-float 68 :displaced-to (colest-part-0 *colest-common-block*) 69 :displaced-index-offset 40)) 70 (colest-wgterr 71 (make-array 40 72 :element-type 'double-float 73 :displaced-to (colest-part-0 *colest-common-block*) 74 :displaced-index-offset 80)) 75 (colest-tolin 76 (make-array 40 77 :element-type 'double-float 78 :displaced-to (colest-part-0 *colest-common-block*) 79 :displaced-index-offset 120)) 80 (colest-root 81 (make-array 40 82 :element-type 'double-float 83 :displaced-to (colest-part-0 *colest-common-block*) 84 :displaced-index-offset 160)) 85 (colest-jtol 86 (make-array 40 87 :element-type 'f2cl-lib:integer4 88 :displaced-to (colest-part-1 *colest-common-block*) 89 :displaced-index-offset 0)) 90 (colest-ltol 91 (make-array 40 92 :element-type 'f2cl-lib:integer4 93 :displaced-to (colest-part-1 *colest-common-block*) 94 :displaced-index-offset 40))) 95 (symbol-macrolet ((ncomp (aref (colord-part-0 *colord-common-block*) 1)) 96 (mmax (aref (colord-part-0 *colord-common-block*) 4)) 97 (m colord-m) 98 (b colbas-b) 99 (acol colbas-acol) 100 (asave colbas-asave) 101 (wgtmsh colest-wgtmsh) 102 (wgterr colest-wgterr) 103 (tolin colest-tolin) 104 (root colest-root) 105 (jtol colest-jtol) 106 (ltol colest-ltol) 107 (ntol (aref (colest-part-1 *colest-common-block*) 80))) 108 (f2cl-lib:with-multi-array-data 109 ((rho double-float rho-%data% rho-%offset%) 110 (coef double-float coef-%data% coef-%offset%)) 111 (prog ((ltoli 0) (i 0) (mtot 0) (jcomp 0) (l 0) (mj 0) (j 0) (iz 0) 112 (koff 0) (dummy (make-array 1 :element-type 'double-float))) 113 (declare (type (array double-float (1)) dummy) 114 (type (f2cl-lib:integer4) koff iz j mj l jcomp mtot i 115 ltoli)) 116 (setf koff (the f2cl-lib:integer4 (truncate (* k (+ k 1)) 2))) 117 (setf iz 1) 118 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 119 ((> j ncomp) nil) 120 (tagbody 121 (setf mj (f2cl-lib:fref m (j) ((1 20)))) 122 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 123 ((> l mj) nil) 124 (tagbody 125 (setf (f2cl-lib:fref wgterr (iz) ((1 40))) 126 (f2cl-lib:fref cnsts1 127 ((f2cl-lib:int-add 128 (f2cl-lib:int-sub koff mj) 129 l)) 130 ((1 28)))) 131 (setf iz (f2cl-lib:int-add iz 1)) 132 label10)))) 133 label10 134 (setf jcomp 1) 135 (setf mtot (f2cl-lib:fref m (1) ((1 20)))) 136 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 137 ((> i ntol) nil) 138 (tagbody 139 (setf ltoli (f2cl-lib:fref ltol (i) ((1 40)))) 140 label20 141 (if (<= ltoli mtot) (go label30)) 142 (setf jcomp (f2cl-lib:int-add jcomp 1)) 143 (setf mtot 144 (f2cl-lib:int-add mtot 145 (f2cl-lib:fref m (jcomp) ((1 20))))) 146 (go label20) 147 label30 148 (setf (f2cl-lib:fref jtol (i) ((1 40))) jcomp) 149 (setf (f2cl-lib:fref wgtmsh (i) ((1 40))) 150 (/ 151 (* 10.0 152 (f2cl-lib:fref cnsts2 153 ((f2cl-lib:int-sub 154 (f2cl-lib:int-add koff ltoli) 155 mtot)) 156 ((1 28)))) 157 (f2cl-lib:fref tolin (i) ((1 40))))) 158 (setf (f2cl-lib:fref root (i) ((1 40))) 159 (/ 1.0 160 (f2cl-lib:dfloat 161 (f2cl-lib:int-add 162 (f2cl-lib:int-sub (f2cl-lib:int-add k mtot) ltoli) 163 1)))) 164 label40)) 165 (f2cl-lib:computed-goto 166 (label50 label60 label70 label80 label90 label100 label110) 167 k) 168 label50 169 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 0.0) 170 (go label120) 171 label60 172 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 173 0.5773502691896257) 174 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 175 (- (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%))) 176 (go label120) 177 label70 178 (setf (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%) 179 0.7745966692414834) 180 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 0.0) 181 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 182 (- (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%))) 183 (go label120) 184 label80 185 (setf (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%) 186 0.8611363115940526) 187 (setf (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%) 188 0.33998104358485626) 189 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 190 (- (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%))) 191 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 192 (- (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%))) 193 (go label120) 194 label90 195 (setf (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%) 196 0.906179845938664) 197 (setf (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%) 198 0.5384693101056831) 199 (setf (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%) 0.0) 200 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 201 (- (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%))) 202 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 203 (- (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%))) 204 (go label120) 205 label100 206 (setf (f2cl-lib:fref rho-%data% (6) ((1 7)) rho-%offset%) 207 0.932469514203152) 208 (setf (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%) 209 0.6612093864662645) 210 (setf (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%) 211 0.2386191860831969) 212 (setf (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%) 213 (- (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%))) 214 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 215 (- (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%))) 216 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 217 (- (f2cl-lib:fref rho-%data% (6) ((1 7)) rho-%offset%))) 218 (go label120) 219 label110 220 (setf (f2cl-lib:fref rho-%data% (7) ((1 7)) rho-%offset%) 221 0.9491079912342758) 222 (setf (f2cl-lib:fref rho-%data% (6) ((1 7)) rho-%offset%) 223 0.7415311855993945) 224 (setf (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%) 225 0.4058451513773972) 226 (setf (f2cl-lib:fref rho-%data% (4) ((1 7)) rho-%offset%) 0.0) 227 (setf (f2cl-lib:fref rho-%data% (3) ((1 7)) rho-%offset%) 228 (- (f2cl-lib:fref rho-%data% (5) ((1 7)) rho-%offset%))) 229 (setf (f2cl-lib:fref rho-%data% (2) ((1 7)) rho-%offset%) 230 (- (f2cl-lib:fref rho-%data% (6) ((1 7)) rho-%offset%))) 231 (setf (f2cl-lib:fref rho-%data% (1) ((1 7)) rho-%offset%) 232 (- (f2cl-lib:fref rho-%data% (7) ((1 7)) rho-%offset%))) 233 label120 234 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 235 ((> j k) nil) 236 (tagbody 237 (setf (f2cl-lib:fref rho-%data% (j) ((1 7)) rho-%offset%) 238 (* 0.5 239 (+ 1.0 240 (f2cl-lib:fref rho-%data% 241 (j) 242 ((1 7)) 243 rho-%offset%)))) 244 label130)) 245 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 246 ((> j k) nil) 247 (tagbody 248 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 249 ((> i k) nil) 250 (tagbody 251 label135 252 (setf (f2cl-lib:fref coef-%data% 253 (i j) 254 ((1 k) (1 1)) 255 coef-%offset%) 256 0.0))) 257 (setf (f2cl-lib:fref coef-%data% 258 (j j) 259 ((1 k) (1 1)) 260 coef-%offset%) 261 1.0) 262 (vmonde rho 263 (f2cl-lib:array-slice coef double-float (1 j) ((1 k) (1 1))) 264 k) 265 label140)) 266 (rkbas 1.0 coef k mmax b dummy 0) 267 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 268 ((> i k) nil) 269 (tagbody 270 (rkbas (f2cl-lib:fref rho-%data% (i) ((1 7)) rho-%offset%) coef 271 k mmax 272 (f2cl-lib:array-slice acol double-float (1 i) ((1 28) (1 7))) 273 dummy 0) 274 label150)) 275 (rkbas (/ 1.0 6.0) coef k mmax 276 (f2cl-lib:array-slice asave double-float (1 1) ((1 28) (1 4))) 277 dummy 0) 278 (rkbas (/ 1.0 3.0) coef k mmax 279 (f2cl-lib:array-slice asave double-float (1 2) ((1 28) (1 4))) 280 dummy 0) 281 (rkbas (/ 2.0 3.0) coef k mmax 282 (f2cl-lib:array-slice asave double-float (1 3) ((1 28) (1 4))) 283 dummy 0) 284 (rkbas (/ 5.0 6.0) coef k mmax 285 (f2cl-lib:array-slice asave double-float (1 4) ((1 28) (1 4))) 286 dummy 0) 287 (go end_label) 288 end_label 289 (return (values nil nil nil)))))))) 290 291(in-package #-gcl #:cl-user #+gcl "CL-USER") 292#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 293(eval-when (:load-toplevel :compile-toplevel :execute) 294 (setf (gethash 'fortran-to-lisp::consts 295 fortran-to-lisp::*f2cl-function-info*) 296 (fortran-to-lisp::make-f2cl-finfo 297 :arg-types '((fortran-to-lisp::integer4) (array double-float (7)) 298 (array double-float (*))) 299 :return-values '(nil nil nil) 300 :calls '(fortran-to-lisp::rkbas fortran-to-lisp::vmonde)))) 301 302