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(labels ((multi-entry-colnew 21 (%name% ncomp m aleft aright zeta ipar ltol tol fixpnt ispace 22 fspace iflag fsub dfsub gsub dgsub guess) 23 (declare (type (array double-float (*)) fspace fixpnt tol zeta) 24 (type double-float aright aleft) 25 (type (array f2cl-lib:integer4 (*)) ispace ltol ipar m) 26 (type (f2cl-lib:integer4) iflag ncomp)) 27 (let ((colloc-rho 28 (make-array 7 29 :element-type 'double-float 30 :displaced-to (colloc-part-0 31 *colloc-common-block*) 32 :displaced-index-offset 0)) 33 (colloc-coef 34 (make-array 49 35 :element-type 'double-float 36 :displaced-to (colloc-part-0 37 *colloc-common-block*) 38 :displaced-index-offset 7)) 39 (colord-mt 40 (make-array 20 41 :element-type 'f2cl-lib:integer4 42 :displaced-to (colord-part-0 43 *colord-common-block*) 44 :displaced-index-offset 5)) 45 (colsid-tzeta 46 (make-array 40 47 :element-type 'double-float 48 :displaced-to (colsid-part-0 49 *colsid-common-block*) 50 :displaced-index-offset 0)) 51 (colest-tolin 52 (make-array 40 53 :element-type 'double-float 54 :displaced-to (colest-part-0 55 *colest-common-block*) 56 :displaced-index-offset 120)) 57 (colest-lttol 58 (make-array 40 59 :element-type 'f2cl-lib:integer4 60 :displaced-to (colest-part-1 61 *colest-common-block*) 62 :displaced-index-offset 40))) 63 (symbol-macrolet ((precis 64 (aref (colout-part-0 *colout-common-block*) 0)) 65 (iout 66 (aref (colout-part-1 *colout-common-block*) 0)) 67 (iprint 68 (aref (colout-part-1 *colout-common-block*) 1)) 69 (rho colloc-rho) 70 (coef colloc-coef) 71 (k 72 (aref (colord-part-0 *colord-common-block*) 0)) 73 (nc 74 (aref (colord-part-0 *colord-common-block*) 1)) 75 (mstar 76 (aref (colord-part-0 *colord-common-block*) 2)) 77 (kd 78 (aref (colord-part-0 *colord-common-block*) 3)) 79 (mmax 80 (aref (colord-part-0 *colord-common-block*) 4)) 81 (mt colord-mt) 82 (n 83 (aref (colapr-part-0 *colapr-common-block*) 0)) 84 (nold 85 (aref (colapr-part-0 *colapr-common-block*) 1)) 86 (nmax 87 (aref (colapr-part-0 *colapr-common-block*) 2)) 88 (nz 89 (aref (colapr-part-0 *colapr-common-block*) 3)) 90 (ndmz 91 (aref (colapr-part-0 *colapr-common-block*) 4)) 92 (mshflg 93 (aref (colmsh-part-0 *colmsh-common-block*) 0)) 94 (mshnum 95 (aref (colmsh-part-0 *colmsh-common-block*) 1)) 96 (mshlmt 97 (aref (colmsh-part-0 *colmsh-common-block*) 2)) 98 (mshalt 99 (aref (colmsh-part-0 *colmsh-common-block*) 3)) 100 (tzeta colsid-tzeta) 101 (tleft 102 (aref (colsid-part-0 *colsid-common-block*) 103 40)) 104 (tright 105 (aref (colsid-part-0 *colsid-common-block*) 106 41)) 107 (nonlin 108 (aref (colnln-part-0 *colnln-common-block*) 0)) 109 (limit 110 (aref (colnln-part-0 *colnln-common-block*) 2)) 111 (icare 112 (aref (colnln-part-0 *colnln-common-block*) 3)) 113 (iguess 114 (aref (colnln-part-0 *colnln-common-block*) 4)) 115 (tolin colest-tolin) 116 (lttol colest-lttol) 117 (ntol 118 (aref (colest-part-1 *colest-common-block*) 119 80))) 120 (f2cl-lib:with-multi-array-data 121 ((m f2cl-lib:integer4 m-%data% m-%offset%) 122 (ipar f2cl-lib:integer4 ipar-%data% ipar-%offset%) 123 (ltol f2cl-lib:integer4 ltol-%data% ltol-%offset%) 124 (ispace f2cl-lib:integer4 ispace-%data% ispace-%offset%) 125 (zeta double-float zeta-%data% zeta-%offset%) 126 (tol double-float tol-%data% tol-%offset%) 127 (fixpnt double-float fixpnt-%data% fixpnt-%offset%) 128 (fspace double-float fspace-%data% fspace-%offset%)) 129 (prog ((ic 0) (k2 0) (idmz 0) (np1 0) (linteg 0) (lpvtw 0) 130 (lpvtg 0) (ldscl 0) (lscl 0) (laccum 0) (lslope 0) 131 (lvalst 0) (lrhs 0) (ldqdmz 0) (ldqz 0) (ldeldz 0) 132 (ldelz 0) (ldmz 0) (lz 0) (lv 0) (lw 0) (lxiold 0) 133 (lg 0) (lxi 0) (nmaxi 0) (nmaxf 0) (nsizef 0) (nfixf 0) 134 (nsizei 0) (nfixi 0) (ib 0) (nrec 0) (ip 0) (nfxpnt 0) 135 (ndimi 0) (ndimf 0) (iread 0) (i 0) (precp1 0.0) 136 (dummy (make-array 1 :element-type 'double-float))) 137 (declare (type (array double-float (1)) dummy) 138 (type double-float precp1) 139 (type (f2cl-lib:integer4) i iread ndimf ndimi 140 nfxpnt ip nrec ib nfixi 141 nsizei nfixf nsizef nmaxf 142 nmaxi lxi lg lxiold lw lv 143 lz ldmz ldelz ldeldz ldqz 144 ldqdmz lrhs lvalst lslope 145 laccum lscl ldscl lpvtg 146 lpvtw linteg np1 idmz k2 147 ic)) 148 (if (eq %name% 'colsys) (go colsys)) 149 colsys 150 (if 151 (<= (f2cl-lib:fref ipar-%data% (7) ((1 1)) ipar-%offset%) 152 0) 153 (f2cl-lib:fformat 6 154 ("~%" "~%" 155 " VERSION *COLNEW* OF COLSYS . " "~%" 156 "~%" "~%"))) 157 (setf iout 6) 158 (setf precis 1.0) 159 label10 160 (setf precis (/ precis 2.0)) 161 (setf precp1 (+ precis 1.0)) 162 (if (> precp1 1.0) (go label10)) 163 (setf precis (* precis 100.0)) 164 (setf iflag -3) 165 (if (or (< ncomp 1) (> ncomp 20)) (go end_label)) 166 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 167 ((> i ncomp) nil) 168 (tagbody 169 (if 170 (or 171 (< (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%) 1) 172 (> (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%) 4)) 173 (go end_label)) 174 label20)) 175 (setf nonlin 176 (f2cl-lib:fref ipar-%data% 177 (1) 178 ((1 1)) 179 ipar-%offset%)) 180 (setf k 181 (f2cl-lib:fref ipar-%data% 182 (2) 183 ((1 1)) 184 ipar-%offset%)) 185 (setf n 186 (f2cl-lib:fref ipar-%data% 187 (3) 188 ((1 1)) 189 ipar-%offset%)) 190 (if (= n 0) (setf n 5)) 191 (setf iread 192 (f2cl-lib:fref ipar-%data% 193 (8) 194 ((1 1)) 195 ipar-%offset%)) 196 (setf iguess 197 (f2cl-lib:fref ipar-%data% 198 (9) 199 ((1 1)) 200 ipar-%offset%)) 201 (if (and (= nonlin 0) (= iguess 1)) (setf iguess 0)) 202 (if (and (>= iguess 2) (= iread 0)) (setf iread 1)) 203 (setf icare 204 (f2cl-lib:fref ipar-%data% 205 (10) 206 ((1 1)) 207 ipar-%offset%)) 208 (setf ntol 209 (f2cl-lib:fref ipar-%data% 210 (4) 211 ((1 1)) 212 ipar-%offset%)) 213 (setf ndimf 214 (f2cl-lib:fref ipar-%data% 215 (5) 216 ((1 1)) 217 ipar-%offset%)) 218 (setf ndimi 219 (f2cl-lib:fref ipar-%data% 220 (6) 221 ((1 1)) 222 ipar-%offset%)) 223 (setf nfxpnt 224 (f2cl-lib:fref ipar-%data% 225 (11) 226 ((1 1)) 227 ipar-%offset%)) 228 (setf iprint 229 (f2cl-lib:fref ipar-%data% 230 (7) 231 ((1 1)) 232 ipar-%offset%)) 233 (setf mstar 0) 234 (setf mmax 0) 235 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 236 ((> i ncomp) nil) 237 (tagbody 238 (setf mmax 239 (f2cl-lib:max0 mmax 240 (f2cl-lib:fref m-%data% 241 (i) 242 ((1 1)) 243 m-%offset%))) 244 (setf mstar 245 (f2cl-lib:int-add mstar 246 (f2cl-lib:fref m-%data% 247 (i) 248 ((1 1)) 249 m-%offset%))) 250 (setf (f2cl-lib:fref mt (i) ((1 20))) 251 (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%)) 252 label30)) 253 (if (= k 0) 254 (setf k 255 (f2cl-lib:max0 (f2cl-lib:int-add mmax 1) 256 (f2cl-lib:int-sub 5 mmax)))) 257 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 258 ((> i mstar) nil) 259 (tagbody 260 label40 261 (setf (f2cl-lib:fref tzeta (i) ((1 40))) 262 (f2cl-lib:fref zeta-%data% 263 (i) 264 ((1 1)) 265 zeta-%offset%)))) 266 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 267 ((> i ntol) nil) 268 (tagbody 269 (setf (f2cl-lib:fref lttol (i) ((1 40))) 270 (f2cl-lib:fref ltol-%data% 271 (i) 272 ((1 1)) 273 ltol-%offset%)) 274 label50 275 (setf (f2cl-lib:fref tolin (i) ((1 40))) 276 (f2cl-lib:fref tol-%data% 277 (i) 278 ((1 1)) 279 tol-%offset%)))) 280 (setf tleft aleft) 281 (setf tright aright) 282 (setf nc ncomp) 283 (setf kd (f2cl-lib:int-mul k ncomp)) 284 (if (> iprint -1) (go label80)) 285 (if (> nonlin 0) (go label60)) 286 (f2cl-lib:fformat iout 287 ("~%" "~%" "~%" 288 " THE NUMBER OF (LINEAR) DIFF EQNS IS " 1 289 (("~3D")) "~%" "~1@T" "THEIR ORDERS ARE" 290 20 (("~3D")) "~%") 291 ncomp 292 (do ((ip 1 (f2cl-lib:int-add ip 1)) 293 (%ret nil)) 294 ((> ip ncomp) (nreverse %ret)) 295 (declare (type f2cl-lib:integer4 ip)) 296 (push 297 (f2cl-lib:fref m-%data% 298 (ip) 299 ((1 1)) 300 m-%offset%) 301 %ret))) 302 (go label70) 303 label60 304 (f2cl-lib:fformat iout 305 ("~%" "~%" "~%" 306 " THE NUMBER OF (NONLINEAR) DIFF EQNS IS " 307 1 (("~3D")) "~%" "~1@T" 308 "THEIR ORDERS ARE" 20 (("~3D")) "~%") 309 ncomp 310 (do ((ip 1 (f2cl-lib:int-add ip 1)) 311 (%ret nil)) 312 ((> ip ncomp) (nreverse %ret)) 313 (declare (type f2cl-lib:integer4 ip)) 314 (push 315 (f2cl-lib:fref m-%data% 316 (ip) 317 ((1 1)) 318 m-%offset%) 319 %ret))) 320 label70 321 (f2cl-lib:fformat iout 322 (" SIDE CONDITION POINTS ZETA" 8 323 (("~10,6,0,'*,F")) 4 324 ("~%" "~27@T" 8 (("~10,6,0,'*,F"))) "~%") 325 (do ((ip 1 (f2cl-lib:int-add ip 1)) 326 (%ret nil)) 327 ((> ip mstar) (nreverse %ret)) 328 (declare (type f2cl-lib:integer4 ip)) 329 (push 330 (f2cl-lib:fref zeta-%data% 331 (ip) 332 ((1 1)) 333 zeta-%offset%) 334 %ret))) 335 (if (> nfxpnt 0) 336 (f2cl-lib:fformat iout 337 (" THERE ARE" 1 (("~5D")) 338 " FIXED POINTS IN THE MESH -" 10 339 (6 (("~10,6,0,'*,F")) "~%") "~%") 340 nfxpnt 341 (do ((ip 1 (f2cl-lib:int-add ip 1)) 342 (%ret nil)) 343 ((> ip nfxpnt) (nreverse %ret)) 344 (declare (type f2cl-lib:integer4 ip)) 345 (push 346 (f2cl-lib:fref fixpnt-%data% 347 (ip) 348 ((1 1)) 349 fixpnt-%offset%) 350 %ret)))) 351 (f2cl-lib:fformat iout 352 (" NUMBER OF COLLOC PTS PER INTERVAL IS" 1 353 (("~3D")) "~%") 354 k) 355 (f2cl-lib:fformat iout 356 (" COMPONENTS OF Z REQUIRING TOLERANCES -" 357 8 ("~7@T" 1 (("~2D")) "~1@T") 4 358 ("~%" "~38@T" 8 (("~10D"))) "~%") 359 (do ((ip 1 (f2cl-lib:int-add ip 1)) 360 (%ret nil)) 361 ((> ip ntol) (nreverse %ret)) 362 (declare (type f2cl-lib:integer4 ip)) 363 (push 364 (f2cl-lib:fref ltol-%data% 365 (ip) 366 ((1 1)) 367 ltol-%offset%) 368 %ret))) 369 (f2cl-lib:fformat iout 370 (" CORRESPONDING ERROR TOLERANCES -" 371 "~6@T" 8 (("~10,2,2,0,'*,,'DE")) 4 372 ("~%" "~39@T" 8 (("~10,2,2,0,'*,,'DE"))) 373 "~%") 374 (do ((ip 1 (f2cl-lib:int-add ip 1)) 375 (%ret nil)) 376 ((> ip ntol) (nreverse %ret)) 377 (declare (type f2cl-lib:integer4 ip)) 378 (push 379 (f2cl-lib:fref tol-%data% 380 (ip) 381 ((1 1)) 382 tol-%offset%) 383 %ret))) 384 (if (>= iguess 2) 385 (f2cl-lib:fformat iout 386 (" INITIAL MESH(ES) AND Z,DMZ PROVIDED BY USER" 387 "~%"))) 388 (if (= iread 2) 389 (f2cl-lib:fformat iout 390 (" NO ADAPTIVE MESH SELECTION" "~%"))) 391 label80 392 (if (or (< k 0) (> k 7)) (go end_label)) 393 (if (< n 0) (go end_label)) 394 (if (or (< iread 0) (> iread 2)) (go end_label)) 395 (if (or (< iguess 0) (> iguess 4)) (go end_label)) 396 (if (or (< icare 0) (> icare 2)) (go end_label)) 397 (if (or (< ntol 0) (> ntol mstar)) (go end_label)) 398 (if (< nfxpnt 0) (go end_label)) 399 (if (or (< iprint -1) (> iprint 1)) (go end_label)) 400 (if (or (< mstar 0) (> mstar 40)) (go end_label)) 401 (setf ip 1) 402 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 403 ((> i mstar) nil) 404 (tagbody 405 (if 406 (or 407 (< 408 (f2cl-lib:dabs 409 (- 410 (f2cl-lib:fref zeta-%data% 411 (i) 412 ((1 1)) 413 zeta-%offset%) 414 aleft)) 415 precis) 416 (< 417 (f2cl-lib:dabs 418 (- 419 (f2cl-lib:fref zeta-%data% 420 (i) 421 ((1 1)) 422 zeta-%offset%) 423 aright)) 424 precis)) 425 (go label100)) 426 label90 427 (if (> ip nfxpnt) (go end_label)) 428 (if 429 (< 430 (- 431 (f2cl-lib:fref zeta-%data% (i) ((1 1)) zeta-%offset%) 432 precis) 433 (f2cl-lib:fref fixpnt-%data% 434 (ip) 435 ((1 1)) 436 fixpnt-%offset%)) 437 (go label95)) 438 (setf ip (f2cl-lib:int-add ip 1)) 439 (go label90) 440 label95 441 (if 442 (< 443 (+ 444 (f2cl-lib:fref zeta-%data% (i) ((1 1)) zeta-%offset%) 445 precis) 446 (f2cl-lib:fref fixpnt-%data% 447 (ip) 448 ((1 1)) 449 fixpnt-%offset%)) 450 (go end_label)) 451 label100)) 452 (setf mshlmt 3) 453 (setf mshflg 0) 454 (setf mshnum 1) 455 (setf mshalt 1) 456 (setf limit 40) 457 (setf nrec 0) 458 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 459 ((> i mstar) nil) 460 (tagbody 461 (setf ib 462 (f2cl-lib:int-sub (f2cl-lib:int-add mstar 1) i)) 463 (if 464 (>= 465 (f2cl-lib:fref zeta-%data% (ib) ((1 1)) zeta-%offset%) 466 aright) 467 (setf nrec i)) 468 label110)) 469 (setf nfixi mstar) 470 (setf nsizei (f2cl-lib:int-add 3 kd mstar)) 471 (setf nfixf 472 (f2cl-lib:int-add 473 (f2cl-lib:int-mul nrec (f2cl-lib:int-mul 2 mstar)) 474 (f2cl-lib:int-mul 5 mstar) 475 3)) 476 (setf nsizef 477 (f2cl-lib:int-add 4 478 (f2cl-lib:int-mul 3 mstar) 479 (f2cl-lib:int-mul 480 (f2cl-lib:int-add kd 5) 481 (f2cl-lib:int-add kd mstar)) 482 (f2cl-lib:int-mul 483 (f2cl-lib:int-sub 484 (f2cl-lib:int-mul 2 mstar) 485 nrec) 486 2 487 mstar))) 488 (setf nmaxf 489 (the f2cl-lib:integer4 490 (truncate (- ndimf nfixf) nsizef))) 491 (setf nmaxi 492 (the f2cl-lib:integer4 493 (truncate (- ndimi nfixi) nsizei))) 494 (if (< iprint 1) 495 (f2cl-lib:fformat iout 496 (" THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (" 497 1 (("~4D")) " (ALLOWED FROM FSPACE)," 498 1 (("~4D")) 499 " (ALLOWED FROM ISPACE) )" "~%") 500 nmaxf 501 nmaxi)) 502 (setf nmax (f2cl-lib:min0 nmaxf nmaxi)) 503 (if (< nmax n) (go end_label)) 504 (if (< nmax (f2cl-lib:int-add nfxpnt 1)) (go end_label)) 505 (if 506 (and 507 (< nmax (f2cl-lib:int-add (f2cl-lib:int-mul 2 nfxpnt) 2)) 508 (< iprint 1)) 509 (f2cl-lib:fformat iout 510 ("~%" 511 " INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE" 512 "~%"))) 513 (setf lxi 1) 514 (setf lg (f2cl-lib:int-add lxi nmax 1)) 515 (setf lxiold 516 (f2cl-lib:int-add lg 517 (f2cl-lib:int-mul 2 518 mstar 519 (f2cl-lib:int-add 520 (f2cl-lib:int-mul 521 nmax 522 (f2cl-lib:int-sub 523 (f2cl-lib:int-mul 524 2 525 mstar) 526 nrec)) 527 nrec)))) 528 (setf lw (f2cl-lib:int-add lxiold nmax 1)) 529 (setf lv 530 (f2cl-lib:int-add lw 531 (f2cl-lib:int-mul (expt kd 2) 532 nmax))) 533 (setf lz 534 (f2cl-lib:int-add lv 535 (f2cl-lib:int-mul mstar kd nmax))) 536 (setf ldmz 537 (f2cl-lib:int-add lz 538 (f2cl-lib:int-mul mstar 539 (f2cl-lib:int-add 540 nmax 541 1)))) 542 (setf ldelz 543 (f2cl-lib:int-add ldmz (f2cl-lib:int-mul kd nmax))) 544 (setf ldeldz 545 (f2cl-lib:int-add ldelz 546 (f2cl-lib:int-mul mstar 547 (f2cl-lib:int-add 548 nmax 549 1)))) 550 (setf ldqz 551 (f2cl-lib:int-add ldeldz 552 (f2cl-lib:int-mul kd nmax))) 553 (setf ldqdmz 554 (f2cl-lib:int-add ldqz 555 (f2cl-lib:int-mul mstar 556 (f2cl-lib:int-add 557 nmax 558 1)))) 559 (setf lrhs 560 (f2cl-lib:int-add ldqdmz 561 (f2cl-lib:int-mul kd nmax))) 562 (setf lvalst 563 (f2cl-lib:int-add lrhs 564 (f2cl-lib:int-mul kd nmax) 565 mstar)) 566 (setf lslope 567 (f2cl-lib:int-add lvalst 568 (f2cl-lib:int-mul 4 mstar nmax))) 569 (setf laccum (f2cl-lib:int-add lslope nmax)) 570 (setf lscl (f2cl-lib:int-add laccum nmax 1)) 571 (setf ldscl 572 (f2cl-lib:int-add lscl 573 (f2cl-lib:int-mul mstar 574 (f2cl-lib:int-add 575 nmax 576 1)))) 577 (setf lpvtg 1) 578 (setf lpvtw 579 (f2cl-lib:int-add lpvtg 580 (f2cl-lib:int-mul mstar 581 (f2cl-lib:int-add 582 nmax 583 1)))) 584 (setf linteg 585 (f2cl-lib:int-add lpvtw (f2cl-lib:int-mul kd nmax))) 586 (if (< iguess 2) (go label160)) 587 (setf nold n) 588 (if (= iguess 4) 589 (setf nold 590 (f2cl-lib:fref ispace-%data% 591 (1) 592 ((1 1)) 593 ispace-%offset%))) 594 (setf nz (f2cl-lib:int-mul mstar (f2cl-lib:int-add nold 1))) 595 (setf ndmz (f2cl-lib:int-mul kd nold)) 596 (setf np1 (f2cl-lib:int-add n 1)) 597 (if (= iguess 4) (setf np1 (f2cl-lib:int-add np1 nold 1))) 598 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 599 ((> i nz) nil) 600 (tagbody 601 label120 602 (setf (f2cl-lib:fref fspace-%data% 603 ((f2cl-lib:int-sub 604 (f2cl-lib:int-add lz i) 605 1)) 606 ((1 1)) 607 fspace-%offset%) 608 (f2cl-lib:fref fspace-%data% 609 ((f2cl-lib:int-add np1 i)) 610 ((1 1)) 611 fspace-%offset%)))) 612 (setf idmz (f2cl-lib:int-add np1 nz)) 613 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 614 ((> i ndmz) nil) 615 (tagbody 616 label125 617 (setf (f2cl-lib:fref fspace-%data% 618 ((f2cl-lib:int-sub 619 (f2cl-lib:int-add ldmz i) 620 1)) 621 ((1 1)) 622 fspace-%offset%) 623 (f2cl-lib:fref fspace-%data% 624 ((f2cl-lib:int-add idmz i)) 625 ((1 1)) 626 fspace-%offset%)))) 627 (setf np1 (f2cl-lib:int-add nold 1)) 628 (if (= iguess 4) (go label140)) 629 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 630 ((> i np1) nil) 631 (tagbody 632 label130 633 (setf (f2cl-lib:fref fspace-%data% 634 ((f2cl-lib:int-sub 635 (f2cl-lib:int-add lxiold i) 636 1)) 637 ((1 1)) 638 fspace-%offset%) 639 (f2cl-lib:fref fspace-%data% 640 ((f2cl-lib:int-sub 641 (f2cl-lib:int-add lxi i) 642 1)) 643 ((1 1)) 644 fspace-%offset%)))) 645 (go label160) 646 label140 647 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 648 ((> i np1) nil) 649 (tagbody 650 label150 651 (setf (f2cl-lib:fref fspace-%data% 652 ((f2cl-lib:int-sub 653 (f2cl-lib:int-add lxiold i) 654 1)) 655 ((1 1)) 656 fspace-%offset%) 657 (f2cl-lib:fref fspace-%data% 658 ((f2cl-lib:int-add n 1 i)) 659 ((1 1)) 660 fspace-%offset%)))) 661 label160 662 (consts k rho coef) 663 (newmsh (f2cl-lib:int-add 3 iread) 664 (f2cl-lib:array-slice fspace double-float (lxi) ((1 1))) 665 (f2cl-lib:array-slice fspace double-float (lxiold) ((1 1))) 666 dummy dummy dummy dummy dummy nfxpnt fixpnt) 667 (if (>= iguess 2) (go label230)) 668 (setf np1 (f2cl-lib:int-add n 1)) 669 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 670 ((> i np1) nil) 671 (tagbody 672 label210 673 (setf (f2cl-lib:fref fspace-%data% 674 ((f2cl-lib:int-sub 675 (f2cl-lib:int-add i lxiold) 676 1)) 677 ((1 1)) 678 fspace-%offset%) 679 (f2cl-lib:fref fspace-%data% 680 ((f2cl-lib:int-sub 681 (f2cl-lib:int-add i lxi) 682 1)) 683 ((1 1)) 684 fspace-%offset%)))) 685 (setf nold n) 686 (if (or (= nonlin 0) (= iguess 1)) (go label230)) 687 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 688 ((> i nz) nil) 689 (tagbody 690 label220 691 (setf (f2cl-lib:fref fspace-%data% 692 ((f2cl-lib:int-add 693 (f2cl-lib:int-sub lz 1) 694 i)) 695 ((1 1)) 696 fspace-%offset%) 697 0.0))) 698 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 699 ((> i ndmz) nil) 700 (tagbody 701 label225 702 (setf (f2cl-lib:fref fspace-%data% 703 ((f2cl-lib:int-add 704 (f2cl-lib:int-sub ldmz 1) 705 i)) 706 ((1 1)) 707 fspace-%offset%) 708 0.0))) 709 label230 710 (if (>= iguess 2) (setf iguess 0)) 711 (multiple-value-bind 712 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 713 var-9 var-10 var-11 var-12 var-13 var-14 var-15 714 var-16 var-17 var-18 var-19 var-20 var-21 var-22 715 var-23 var-24 var-25 var-26 var-27) 716 (contrl 717 (f2cl-lib:array-slice fspace 718 double-float 719 (lxi) 720 ((1 1))) 721 (f2cl-lib:array-slice fspace 722 double-float 723 (lxiold) 724 ((1 1))) 725 (f2cl-lib:array-slice fspace double-float (lz) ((1 1))) 726 (f2cl-lib:array-slice fspace 727 double-float 728 (ldmz) 729 ((1 1))) 730 (f2cl-lib:array-slice fspace 731 double-float 732 (lrhs) 733 ((1 1))) 734 (f2cl-lib:array-slice fspace 735 double-float 736 (ldelz) 737 ((1 1))) 738 (f2cl-lib:array-slice fspace 739 double-float 740 (ldeldz) 741 ((1 1))) 742 (f2cl-lib:array-slice fspace 743 double-float 744 (ldqz) 745 ((1 1))) 746 (f2cl-lib:array-slice fspace 747 double-float 748 (ldqdmz) 749 ((1 1))) 750 (f2cl-lib:array-slice fspace double-float (lg) ((1 1))) 751 (f2cl-lib:array-slice fspace double-float (lw) ((1 1))) 752 (f2cl-lib:array-slice fspace double-float (lv) ((1 1))) 753 (f2cl-lib:array-slice fspace 754 double-float 755 (lvalst) 756 ((1 1))) 757 (f2cl-lib:array-slice fspace 758 double-float 759 (lslope) 760 ((1 1))) 761 (f2cl-lib:array-slice fspace 762 double-float 763 (lscl) 764 ((1 1))) 765 (f2cl-lib:array-slice fspace 766 double-float 767 (ldscl) 768 ((1 1))) 769 (f2cl-lib:array-slice fspace 770 double-float 771 (laccum) 772 ((1 1))) 773 (f2cl-lib:array-slice ispace 774 f2cl-lib:integer4 775 (lpvtg) 776 ((1 1))) 777 (f2cl-lib:array-slice ispace 778 f2cl-lib:integer4 779 (linteg) 780 ((1 1))) 781 (f2cl-lib:array-slice ispace 782 f2cl-lib:integer4 783 (lpvtw) 784 ((1 1))) 785 nfxpnt fixpnt iflag fsub dfsub gsub dgsub guess) 786 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 787 var-7 var-8 var-9 var-10 var-11 var-12 788 var-13 var-14 var-15 var-16 var-17 var-18 789 var-19 var-20 var-21 var-23 var-24 var-25 790 var-26 var-27)) 791 (setf iflag var-22)) 792 (setf (f2cl-lib:fref ispace-%data% 793 (1) 794 ((1 1)) 795 ispace-%offset%) 796 n) 797 (setf (f2cl-lib:fref ispace-%data% 798 (2) 799 ((1 1)) 800 ispace-%offset%) 801 k) 802 (setf (f2cl-lib:fref ispace-%data% 803 (3) 804 ((1 1)) 805 ispace-%offset%) 806 ncomp) 807 (setf (f2cl-lib:fref ispace-%data% 808 (4) 809 ((1 1)) 810 ispace-%offset%) 811 mstar) 812 (setf (f2cl-lib:fref ispace-%data% 813 (5) 814 ((1 1)) 815 ispace-%offset%) 816 mmax) 817 (setf (f2cl-lib:fref ispace-%data% 818 (6) 819 ((1 1)) 820 ispace-%offset%) 821 (f2cl-lib:int-add nz ndmz n 2)) 822 (setf k2 (f2cl-lib:int-mul k k)) 823 (setf (f2cl-lib:fref ispace-%data% 824 (7) 825 ((1 1)) 826 ispace-%offset%) 827 (f2cl-lib:int-sub 828 (f2cl-lib:int-add 829 (f2cl-lib:fref ispace-%data% 830 (6) 831 ((1 1)) 832 ispace-%offset%) 833 k2) 834 1)) 835 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 836 ((> i ncomp) nil) 837 (tagbody 838 label240 839 (setf (f2cl-lib:fref ispace-%data% 840 ((f2cl-lib:int-add 7 i)) 841 ((1 1)) 842 ispace-%offset%) 843 (f2cl-lib:fref m-%data% 844 (i) 845 ((1 1)) 846 m-%offset%)))) 847 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 848 ((> i nz) nil) 849 (tagbody 850 label250 851 (setf (f2cl-lib:fref fspace-%data% 852 ((f2cl-lib:int-add n 1 i)) 853 ((1 1)) 854 fspace-%offset%) 855 (f2cl-lib:fref fspace-%data% 856 ((f2cl-lib:int-add 857 (f2cl-lib:int-sub lz 1) 858 i)) 859 ((1 1)) 860 fspace-%offset%)))) 861 (setf idmz (f2cl-lib:int-add n 1 nz)) 862 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 863 ((> i ndmz) nil) 864 (tagbody 865 label255 866 (setf (f2cl-lib:fref fspace-%data% 867 ((f2cl-lib:int-add idmz i)) 868 ((1 1)) 869 fspace-%offset%) 870 (f2cl-lib:fref fspace-%data% 871 ((f2cl-lib:int-add 872 (f2cl-lib:int-sub ldmz 1) 873 i)) 874 ((1 1)) 875 fspace-%offset%)))) 876 (setf ic (f2cl-lib:int-add idmz ndmz)) 877 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 878 ((> i k2) nil) 879 (tagbody 880 label258 881 (setf (f2cl-lib:fref fspace-%data% 882 ((f2cl-lib:int-add ic i)) 883 ((1 1)) 884 fspace-%offset%) 885 (f2cl-lib:fref coef (i) ((1 49)))))) 886 (go end_label) 887 end_label 888 (return 889 (values nil 890 nil 891 nil 892 nil 893 nil 894 nil 895 nil 896 nil 897 nil 898 nil 899 nil 900 iflag 901 nil 902 nil 903 nil 904 nil 905 nil)))))))) 906 (defun colnew 907 (ncomp m aleft aright zeta ipar ltol tol fixpnt ispace fspace iflag 908 fsub dfsub gsub dgsub guess) 909 (multiple-value-bind 910 (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16) 911 (multi-entry-colnew 'colnew ncomp m aleft aright zeta ipar ltol tol 912 fixpnt ispace fspace iflag fsub dfsub gsub dgsub guess) 913 (values v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16))) 914 (defun colsys 915 (ncomp m aleft aright zeta ipar ltol tol fixpnt ispace fspace iflag 916 fsub dfsub gsub dgsub guess) 917 (multiple-value-bind 918 (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16) 919 (multi-entry-colnew 'colsys ncomp m aleft aright zeta ipar ltol tol 920 fixpnt ispace fspace iflag fsub dfsub gsub dgsub guess) 921 (values v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16)))) 922 923(in-package #-gcl #:cl-user #+gcl "CL-USER") 924#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 925(eval-when (:load-toplevel :compile-toplevel :execute) 926 (setf (gethash 'fortran-to-lisp::colnew 927 fortran-to-lisp::*f2cl-function-info*) 928 (fortran-to-lisp::make-f2cl-finfo 929 :arg-types '((fortran-to-lisp::integer4) 930 (array fortran-to-lisp::integer4 (1)) double-float 931 double-float (array double-float (1)) 932 (array fortran-to-lisp::integer4 (1)) 933 (array fortran-to-lisp::integer4 (1)) 934 (array double-float (1)) (array double-float (1)) 935 (array fortran-to-lisp::integer4 (1)) 936 (array double-float (1)) (fortran-to-lisp::integer4) t 937 t t t t) 938 :return-values '(nil nil nil nil nil nil nil nil nil nil nil 939 fortran-to-lisp::iflag nil nil nil nil nil) 940 :calls '(fortran-to-lisp::contrl fortran-to-lisp::newmsh 941 fortran-to-lisp::consts)))) 942 943