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 newmsh (mode xi xiold z dmz valstr slope accum nfxpnt fixpnt) 21 (declare (type (array double-float (*)) fixpnt accum slope valstr dmz z xiold 22 xi) 23 (type (f2cl-lib:integer4) nfxpnt mode)) 24 (let ((colord-m 25 (make-array 20 26 :element-type 'f2cl-lib:integer4 27 :displaced-to (colord-part-0 *colord-common-block*) 28 :displaced-index-offset 5)) 29 (colbas-asave 30 (make-array 112 31 :element-type 'double-float 32 :displaced-to (colbas-part-0 *colbas-common-block*) 33 :displaced-index-offset 224)) 34 (colest-wgtmsh 35 (make-array 40 36 :element-type 'double-float 37 :displaced-to (colest-part-0 *colest-common-block*) 38 :displaced-index-offset 40)) 39 (colest-root 40 (make-array 40 41 :element-type 'double-float 42 :displaced-to (colest-part-0 *colest-common-block*) 43 :displaced-index-offset 160)) 44 (colest-jtol 45 (make-array 40 46 :element-type 'f2cl-lib:integer4 47 :displaced-to (colest-part-1 *colest-common-block*) 48 :displaced-index-offset 0)) 49 (colest-ltol 50 (make-array 40 51 :element-type 'f2cl-lib:integer4 52 :displaced-to (colest-part-1 *colest-common-block*) 53 :displaced-index-offset 40))) 54 (symbol-macrolet ((precis (aref (colout-part-0 *colout-common-block*) 0)) 55 (iout (aref (colout-part-1 *colout-common-block*) 0)) 56 (iprint (aref (colout-part-1 *colout-common-block*) 1)) 57 (k (aref (colord-part-0 *colord-common-block*) 0)) 58 (ncomp (aref (colord-part-0 *colord-common-block*) 1)) 59 (mstar (aref (colord-part-0 *colord-common-block*) 2)) 60 (kd (aref (colord-part-0 *colord-common-block*) 3)) 61 (mmax (aref (colord-part-0 *colord-common-block*) 4)) 62 (m colord-m) 63 (n (aref (colapr-part-0 *colapr-common-block*) 0)) 64 (nold (aref (colapr-part-0 *colapr-common-block*) 1)) 65 (nmax (aref (colapr-part-0 *colapr-common-block*) 2)) 66 (nz (aref (colapr-part-0 *colapr-common-block*) 3)) 67 (ndmz (aref (colapr-part-0 *colapr-common-block*) 4)) 68 (mshflg (aref (colmsh-part-0 *colmsh-common-block*) 0)) 69 (mshnum (aref (colmsh-part-0 *colmsh-common-block*) 1)) 70 (mshlmt (aref (colmsh-part-0 *colmsh-common-block*) 2)) 71 (mshalt (aref (colmsh-part-0 *colmsh-common-block*) 3)) 72 (iguess (aref (colnln-part-0 *colnln-common-block*) 4)) 73 (aleft (aref (colsid-part-0 *colsid-common-block*) 40)) 74 (aright (aref (colsid-part-0 *colsid-common-block*) 41)) 75 (asave colbas-asave) 76 (wgtmsh colest-wgtmsh) 77 (root colest-root) 78 (jtol colest-jtol) 79 (ltol colest-ltol) 80 (ntol (aref (colest-part-1 *colest-common-block*) 80))) 81 (f2cl-lib:with-multi-array-data 82 ((xi double-float xi-%data% xi-%offset%) 83 (xiold double-float xiold-%data% xiold-%offset%) 84 (z double-float z-%data% z-%offset%) 85 (dmz double-float dmz-%data% dmz-%offset%) 86 (valstr double-float valstr-%data% valstr-%offset%) 87 (slope double-float slope-%data% slope-%offset%) 88 (accum double-float accum-%data% accum-%offset%) 89 (fixpnt double-float fixpnt-%data% fixpnt-%offset%)) 90 (prog ((lcarry 0) (l 0) (tsum 0.0) (accr 0.0) (lnew 0) (lold 0) 91 (accl 0.0) (in 0) (nmax2 0) (nmx 0) (naccum 0) (degequ 0.0) 92 (avrg 0.0) (temp 0.0) (iflip 0) (slphmx 0.0) (jz 0) (jj 0) 93 (oneovh 0.0) (hiold 0.0) (x 0.0) (hd6 0.0) (kstore 0) (n2 0) 94 (dx 0.0) (nregn 0) (nmin 0) (iright 0) (xright 0.0) (xleft 0.0) 95 (ileft 0) (np1 0) (j 0) (i 0) (noldp1 0) (nfxp1 0) 96 (d2 (make-array 40 :element-type 'double-float)) 97 (d1 (make-array 40 :element-type 'double-float)) 98 (dummy (make-array 1 :element-type 'double-float))) 99 (declare (type (array double-float (1)) dummy) 100 (type (array double-float (40)) d1 d2) 101 (type double-float xleft xright dx hd6 x hiold oneovh slphmx 102 temp avrg degequ accl accr tsum) 103 (type (f2cl-lib:integer4) nfxp1 noldp1 i j np1 ileft iright 104 nmin nregn n2 kstore jj jz iflip 105 naccum nmx nmax2 in lold lnew l 106 lcarry)) 107 (setf nfxp1 (f2cl-lib:int-add nfxpnt 1)) 108 (f2cl-lib:computed-goto (label180 label100 label50 label20 label10) 109 mode) 110 label10 111 (setf mshlmt 1) 112 label20 113 (if (< iguess 2) (go label40)) 114 (setf noldp1 (f2cl-lib:int-add nold 1)) 115 (if (< iprint 1) 116 (f2cl-lib:fformat iout 117 ("~%" " THE FORMER MESH (OF" 1 (("~5D")) 118 " SUBINTERVALS)," 100 119 ("~%" 8 (("~12,6,0,'*,F"))) "~%") 120 nold 121 (do ((i 1 (f2cl-lib:int-add i 1)) 122 (%ret nil)) 123 ((> i noldp1) (nreverse %ret)) 124 (declare (type f2cl-lib:integer4 i)) 125 (push 126 (f2cl-lib:fref xiold-%data% 127 (i) 128 ((1 1)) 129 xiold-%offset%) 130 %ret)))) 131 (if (/= iguess 3) (go label40)) 132 (setf n (the f2cl-lib:integer4 (truncate nold 2))) 133 (setf i 0) 134 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 2)) 135 ((> j nold) nil) 136 (tagbody 137 (setf i (f2cl-lib:int-add i 1)) 138 label30 139 (setf (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%) 140 (f2cl-lib:fref xiold-%data% 141 (j) 142 ((1 1)) 143 xiold-%offset%)))) 144 label40 145 (setf np1 (f2cl-lib:int-add n 1)) 146 (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft) 147 (setf (f2cl-lib:fref xi-%data% (np1) ((1 1)) xi-%offset%) aright) 148 (go label320) 149 label50 150 (if (< n nfxp1) (setf n nfxp1)) 151 (setf np1 (f2cl-lib:int-add n 1)) 152 (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft) 153 (setf ileft 1) 154 (setf xleft aleft) 155 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 156 ((> j nfxp1) nil) 157 (tagbody 158 (setf xright aright) 159 (setf iright np1) 160 (if (= j nfxp1) (go label60)) 161 (setf xright 162 (f2cl-lib:fref fixpnt-%data% 163 (j) 164 ((1 1)) 165 fixpnt-%offset%)) 166 (setf nmin 167 (f2cl-lib:int 168 (+ 169 (* (/ (- xright aleft) (- aright aleft)) 170 (f2cl-lib:dfloat n)) 171 1.5))) 172 (if (> nmin (f2cl-lib:int-add (f2cl-lib:int-sub n nfxpnt) j)) 173 (setf nmin (f2cl-lib:int-add (f2cl-lib:int-sub n nfxpnt) j))) 174 (setf iright (f2cl-lib:max0 (f2cl-lib:int-add ileft 1) nmin)) 175 label60 176 (setf (f2cl-lib:fref xi-%data% (iright) ((1 1)) xi-%offset%) 177 xright) 178 (setf nregn (f2cl-lib:int-sub iright ileft 1)) 179 (if (= nregn 0) (go label80)) 180 (setf dx 181 (/ (- xright xleft) 182 (f2cl-lib:dfloat (f2cl-lib:int-add nregn 1)))) 183 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 184 ((> i nregn) nil) 185 (tagbody 186 label70 187 (setf (f2cl-lib:fref xi-%data% 188 ((f2cl-lib:int-add ileft i)) 189 ((1 1)) 190 xi-%offset%) 191 (+ xleft (* (f2cl-lib:dfloat i) dx))))) 192 label80 193 (setf ileft iright) 194 (setf xleft xright) 195 label90)) 196 (go label320) 197 label100 198 (setf n2 (f2cl-lib:int-mul 2 n)) 199 (if (<= n2 nmax) (go label120)) 200 (if (= mode 2) (go label110)) 201 (setf n (the f2cl-lib:integer4 (truncate nmax 2))) 202 (go label220) 203 label110 204 (if (< iprint 1) 205 (f2cl-lib:fformat iout ("~%" " EXPECTED N TOO LARGE " "~%"))) 206 (setf n n2) 207 (go end_label) 208 label120 209 (if (= mshflg 0) (go label140)) 210 (setf kstore 1) 211 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 212 ((> i nold) nil) 213 (tagbody 214 (setf hd6 215 (/ 216 (- 217 (f2cl-lib:fref xiold-%data% 218 ((f2cl-lib:int-add i 1)) 219 ((1 1)) 220 xiold-%offset%) 221 (f2cl-lib:fref xiold-%data% 222 (i) 223 ((1 1)) 224 xiold-%offset%)) 225 6.0)) 226 (setf x 227 (+ 228 (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%) 229 hd6)) 230 (multiple-value-bind 231 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 232 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 233 (approx i x 234 (f2cl-lib:array-slice valstr double-float (kstore) ((1 1))) 235 (f2cl-lib:array-slice asave 236 double-float 237 (1 1) 238 ((1 28) (1 4))) 239 dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0) 240 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 241 var-9 var-10 var-11 var-12 var-13 var-14 242 var-15 var-16)) 243 (setf i var-0) 244 (setf x var-1)) 245 (setf x (+ x (* 4.0 hd6))) 246 (setf kstore 247 (f2cl-lib:int-add kstore (f2cl-lib:int-mul 3 mstar))) 248 (multiple-value-bind 249 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 250 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 251 (approx i x 252 (f2cl-lib:array-slice valstr double-float (kstore) ((1 1))) 253 (f2cl-lib:array-slice asave 254 double-float 255 (1 4) 256 ((1 28) (1 4))) 257 dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0) 258 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 259 var-9 var-10 var-11 var-12 var-13 var-14 260 var-15 var-16)) 261 (setf i var-0) 262 (setf x var-1)) 263 (setf kstore (f2cl-lib:int-add kstore mstar)) 264 label130)) 265 (go label160) 266 label140 267 (setf kstore 1) 268 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 269 ((> i n) nil) 270 (tagbody 271 (setf x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 272 (setf hd6 273 (/ 274 (- 275 (f2cl-lib:fref xi-%data% 276 ((f2cl-lib:int-add i 1)) 277 ((1 1)) 278 xi-%offset%) 279 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 280 6.0)) 281 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 282 ((> j 4) nil) 283 (tagbody 284 (setf x (+ x hd6)) 285 (if (= j 3) (setf x (+ x hd6))) 286 (multiple-value-bind 287 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 288 var-9 var-10 var-11 var-12 var-13 var-14 var-15 289 var-16) 290 (approx i x 291 (f2cl-lib:array-slice valstr 292 double-float 293 (kstore) 294 ((1 1))) 295 (f2cl-lib:array-slice asave 296 double-float 297 (1 j) 298 ((1 28) (1 4))) 299 dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0) 300 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 301 var-9 var-10 var-11 var-12 var-13 var-14 302 var-15 var-16)) 303 (setf i var-0) 304 (setf x var-1)) 305 (setf kstore (f2cl-lib:int-add kstore mstar)) 306 label150)))) 307 label150 308 label160 309 (setf mshflg 0) 310 (setf mshnum 1) 311 (setf mode 2) 312 (setf j 2) 313 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 314 ((> i n) nil) 315 (tagbody 316 (setf (f2cl-lib:fref xi-%data% (j) ((1 1)) xi-%offset%) 317 (/ 318 (+ 319 (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%) 320 (f2cl-lib:fref xiold-%data% 321 ((f2cl-lib:int-add i 1)) 322 ((1 1)) 323 xiold-%offset%)) 324 2.0)) 325 (setf (f2cl-lib:fref xi-%data% 326 ((f2cl-lib:int-add j 1)) 327 ((1 1)) 328 xi-%offset%) 329 (f2cl-lib:fref xiold-%data% 330 ((f2cl-lib:int-add i 1)) 331 ((1 1)) 332 xiold-%offset%)) 333 label170 334 (setf j (f2cl-lib:int-add j 2)))) 335 (setf n n2) 336 (go label320) 337 label180 338 (if (= nold 1) (go label100)) 339 (if (<= nold (f2cl-lib:int-mul 2 nfxpnt)) (go label100)) 340 (setf i 1) 341 (setf hiold 342 (- (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%) 343 (f2cl-lib:fref xiold-%data% (1) ((1 1)) xiold-%offset%))) 344 (horder 1 d1 hiold dmz ncomp k) 345 (setf hiold 346 (- (f2cl-lib:fref xiold-%data% (3) ((1 1)) xiold-%offset%) 347 (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%))) 348 (horder 2 d2 hiold dmz ncomp k) 349 (setf (f2cl-lib:fref accum-%data% (1) ((1 1)) accum-%offset%) 0.0) 350 (setf (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%) 0.0) 351 (setf oneovh 352 (/ 2.0 353 (- (f2cl-lib:fref xiold-%data% (3) ((1 1)) xiold-%offset%) 354 (f2cl-lib:fref xiold-%data% 355 (1) 356 ((1 1)) 357 xiold-%offset%)))) 358 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 359 ((> j ntol) nil) 360 (tagbody 361 (setf jj (f2cl-lib:fref jtol (j) ((1 40)))) 362 (setf jz (f2cl-lib:fref ltol (j) ((1 40)))) 363 label190 364 (setf (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%) 365 (f2cl-lib:dmax1 366 (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%) 367 (expt 368 (/ 369 (* 370 (f2cl-lib:dabs 371 (- (f2cl-lib:fref d2 (jj) ((1 40))) 372 (f2cl-lib:fref d1 (jj) ((1 40))))) 373 (f2cl-lib:fref wgtmsh (j) ((1 40))) 374 oneovh) 375 (+ 1.0 376 (f2cl-lib:dabs 377 (f2cl-lib:fref z-%data% 378 (jz) 379 ((1 1)) 380 z-%offset%)))) 381 (f2cl-lib:fref root (j) ((1 40)))))))) 382 (setf slphmx 383 (* (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%) 384 (- (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%) 385 (f2cl-lib:fref xiold-%data% 386 (1) 387 ((1 1)) 388 xiold-%offset%)))) 389 (setf (f2cl-lib:fref accum-%data% (2) ((1 1)) accum-%offset%) slphmx) 390 (setf iflip 1) 391 (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) 392 ((> i nold) nil) 393 (tagbody 394 (setf hiold 395 (- 396 (f2cl-lib:fref xiold-%data% 397 ((f2cl-lib:int-add i 1)) 398 ((1 1)) 399 xiold-%offset%) 400 (f2cl-lib:fref xiold-%data% 401 (i) 402 ((1 1)) 403 xiold-%offset%))) 404 (if (= iflip -1) (horder i d1 hiold dmz ncomp k)) 405 (if (= iflip 1) (horder i d2 hiold dmz ncomp k)) 406 (setf oneovh 407 (/ 2.0 408 (- 409 (f2cl-lib:fref xiold-%data% 410 ((f2cl-lib:int-add i 1)) 411 ((1 1)) 412 xiold-%offset%) 413 (f2cl-lib:fref xiold-%data% 414 ((f2cl-lib:int-sub i 1)) 415 ((1 1)) 416 xiold-%offset%)))) 417 (setf (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%) 418 0.0) 419 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 420 ((> j ntol) nil) 421 (tagbody 422 (setf jj (f2cl-lib:fref jtol (j) ((1 40)))) 423 (setf jz 424 (f2cl-lib:int-add (f2cl-lib:fref ltol (j) ((1 40))) 425 (f2cl-lib:int-mul 426 (f2cl-lib:int-sub i 1) 427 mstar))) 428 label200 429 (setf (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%) 430 (f2cl-lib:dmax1 431 (f2cl-lib:fref slope-%data% 432 (i) 433 ((1 1)) 434 slope-%offset%) 435 (expt 436 (/ 437 (* 438 (f2cl-lib:dabs 439 (- (f2cl-lib:fref d2 (jj) ((1 40))) 440 (f2cl-lib:fref d1 (jj) ((1 40))))) 441 (f2cl-lib:fref wgtmsh (j) ((1 40))) 442 oneovh) 443 (+ 1.0 444 (f2cl-lib:dabs 445 (f2cl-lib:fref z-%data% 446 (jz) 447 ((1 1)) 448 z-%offset%)))) 449 (f2cl-lib:fref root (j) ((1 40)))))))) 450 (setf temp 451 (* 452 (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%) 453 (- 454 (f2cl-lib:fref xiold-%data% 455 ((f2cl-lib:int-add i 1)) 456 ((1 1)) 457 xiold-%offset%) 458 (f2cl-lib:fref xiold-%data% 459 (i) 460 ((1 1)) 461 xiold-%offset%)))) 462 (setf slphmx (f2cl-lib:dmax1 slphmx temp)) 463 (setf (f2cl-lib:fref accum-%data% 464 ((f2cl-lib:int-add i 1)) 465 ((1 1)) 466 accum-%offset%) 467 (+ 468 (f2cl-lib:fref accum-%data% (i) ((1 1)) accum-%offset%) 469 temp)) 470 label210 471 (setf iflip (f2cl-lib:int-sub iflip)))) 472 (setf avrg 473 (/ 474 (f2cl-lib:fref accum-%data% 475 ((f2cl-lib:int-add nold 1)) 476 ((1 1)) 477 accum-%offset%) 478 (f2cl-lib:dfloat nold))) 479 (setf degequ (/ avrg (f2cl-lib:dmax1 slphmx precis))) 480 (setf naccum 481 (f2cl-lib:int 482 (+ 483 (f2cl-lib:fref accum-%data% 484 ((f2cl-lib:int-add nold 1)) 485 ((1 1)) 486 accum-%offset%) 487 1.0))) 488 (if (< iprint 0) 489 (f2cl-lib:fformat iout 490 ("~%" " MESH SELECTION INFO," "~%" 491 " DEGREE OF EQUIDISTRIBUTION = " 1 492 (("~8,5,0,'*,F")) 493 " PREDICTION FOR REQUIRED N =" 1 (("~8D")) 494 "~%") 495 degequ 496 naccum)) 497 (if (< avrg precis) (go label100)) 498 (if (>= degequ 0.5) (go label100)) 499 (setf nmx 500 (the f2cl-lib:integer4 501 (truncate (f2cl-lib:max0 (+ nold 1) naccum) 2))) 502 (setf nmax2 (the f2cl-lib:integer4 (truncate nmax 2))) 503 (setf n (f2cl-lib:min0 nmax2 nold nmx)) 504 label220 505 (setf noldp1 (f2cl-lib:int-add nold 1)) 506 (if (< n nfxp1) (setf n nfxp1)) 507 (setf mshnum (f2cl-lib:int-add mshnum 1)) 508 (if (< n nold) (setf mshnum mshlmt)) 509 (if (> n (the f2cl-lib:integer4 (truncate nold 2))) (setf mshalt 1)) 510 (if (= n (the f2cl-lib:integer4 (truncate nold 2))) 511 (setf mshalt (f2cl-lib:int-add mshalt 1))) 512 (setf mshflg 0) 513 (setf in 1) 514 (setf accl 0.0) 515 (setf lold 2) 516 (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft) 517 (setf (f2cl-lib:fref xi-%data% 518 ((f2cl-lib:int-add n 1)) 519 ((1 1)) 520 xi-%offset%) 521 aright) 522 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 523 ((> i nfxp1) nil) 524 (tagbody 525 (if (= i nfxp1) (go label250)) 526 (f2cl-lib:fdo (j lold (f2cl-lib:int-add j 1)) 527 ((> j noldp1) nil) 528 (tagbody 529 (setf lnew j) 530 (if 531 (<= 532 (f2cl-lib:fref fixpnt-%data% (i) ((1 1)) fixpnt-%offset%) 533 (f2cl-lib:fref xiold-%data% (j) ((1 1)) xiold-%offset%)) 534 (go label240)) 535 label230)) 536 label240 537 (setf accr 538 (+ 539 (f2cl-lib:fref accum-%data% 540 (lnew) 541 ((1 1)) 542 accum-%offset%) 543 (* 544 (- 545 (f2cl-lib:fref fixpnt-%data% 546 (i) 547 ((1 1)) 548 fixpnt-%offset%) 549 (f2cl-lib:fref xiold-%data% 550 (lnew) 551 ((1 1)) 552 xiold-%offset%)) 553 (f2cl-lib:fref slope-%data% 554 ((f2cl-lib:int-sub lnew 1)) 555 ((1 1)) 556 slope-%offset%)))) 557 (setf nregn 558 (f2cl-lib:int 559 (- 560 (* 561 (/ (- accr accl) 562 (f2cl-lib:fref accum-%data% 563 (noldp1) 564 ((1 1)) 565 accum-%offset%)) 566 (f2cl-lib:dfloat n)) 567 0.5))) 568 (setf nregn 569 (f2cl-lib:min0 nregn 570 (f2cl-lib:int-add 571 (f2cl-lib:int-sub n in nfxp1) 572 i))) 573 (setf (f2cl-lib:fref xi-%data% 574 ((f2cl-lib:int-add in nregn 1)) 575 ((1 1)) 576 xi-%offset%) 577 (f2cl-lib:fref fixpnt-%data% 578 (i) 579 ((1 1)) 580 fixpnt-%offset%)) 581 (go label260) 582 label250 583 (setf accr 584 (f2cl-lib:fref accum-%data% 585 (noldp1) 586 ((1 1)) 587 accum-%offset%)) 588 (setf lnew noldp1) 589 (setf nregn (f2cl-lib:int-sub n in)) 590 label260 591 (if (= nregn 0) (go label300)) 592 (setf temp accl) 593 (setf tsum 594 (/ (- accr accl) 595 (f2cl-lib:dfloat (f2cl-lib:int-add nregn 1)))) 596 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 597 ((> j nregn) nil) 598 (tagbody 599 (setf in (f2cl-lib:int-add in 1)) 600 (setf temp (+ temp tsum)) 601 (f2cl-lib:fdo (l lold (f2cl-lib:int-add l 1)) 602 ((> l lnew) nil) 603 (tagbody 604 (setf lcarry l) 605 (if 606 (<= temp 607 (f2cl-lib:fref accum-%data% 608 (l) 609 ((1 1)) 610 accum-%offset%)) 611 (go label280)) 612 label270)) 613 label280 614 (setf lold lcarry) 615 label290 616 (setf (f2cl-lib:fref xi-%data% (in) ((1 1)) xi-%offset%) 617 (+ 618 (f2cl-lib:fref xiold-%data% 619 ((f2cl-lib:int-sub lold 1)) 620 ((1 1)) 621 xiold-%offset%) 622 (/ 623 (- temp 624 (f2cl-lib:fref accum-%data% 625 ((f2cl-lib:int-sub lold 1)) 626 ((1 1)) 627 accum-%offset%)) 628 (f2cl-lib:fref slope-%data% 629 ((f2cl-lib:int-sub lold 1)) 630 ((1 1)) 631 slope-%offset%)))))) 632 label300 633 (setf in (f2cl-lib:int-add in 1)) 634 (setf accl accr) 635 (setf lold lnew) 636 label310)) 637 (setf mode 1) 638 label320 639 (setf np1 (f2cl-lib:int-add n 1)) 640 (if (< iprint 1) 641 (f2cl-lib:fformat iout 642 ("~%" " THE NEW MESH (OF" 1 (("~5D")) 643 " SUBINTERVALS), " 100 644 ("~%" 8 (("~12,6,0,'*,F"))) "~%") 645 n 646 (do ((i 1 (f2cl-lib:int-add i 1)) 647 (%ret nil)) 648 ((> i np1) (nreverse %ret)) 649 (declare (type f2cl-lib:integer4 i)) 650 (push 651 (f2cl-lib:fref xi-%data% 652 (i) 653 ((1 1)) 654 xi-%offset%) 655 %ret)))) 656 (setf nz (f2cl-lib:int-mul mstar (f2cl-lib:int-add n 1))) 657 (setf ndmz (f2cl-lib:int-mul kd n)) 658 (go end_label) 659 end_label 660 (return (values mode nil nil nil nil nil nil nil nil nil))))))) 661 662(in-package #-gcl #:cl-user #+gcl "CL-USER") 663#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 664(eval-when (:load-toplevel :compile-toplevel :execute) 665 (setf (gethash 'fortran-to-lisp::newmsh 666 fortran-to-lisp::*f2cl-function-info*) 667 (fortran-to-lisp::make-f2cl-finfo 668 :arg-types '((fortran-to-lisp::integer4) (array double-float (1)) 669 (array double-float (1)) (array double-float (1)) 670 (array double-float (1)) (array double-float (1)) 671 (array double-float (1)) (array double-float (1)) 672 (fortran-to-lisp::integer4) (array double-float (1))) 673 :return-values '(fortran-to-lisp::mode nil nil nil nil nil nil nil 674 nil nil) 675 :calls '(fortran-to-lisp::horder fortran-to-lisp::approx)))) 676 677