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 lsyslv 21 (msing xi xiold z dmz delz deldmz g w v rhs dmzo integs ipvtg ipvtw 22 rnorm mode fsub dfsub gsub dgsub guess) 23 (declare (type double-float rnorm) 24 (type (array f2cl-lib:integer4 (*)) ipvtw ipvtg) 25 (type (array f2cl-lib:integer4 (*)) integs) 26 (type (array double-float (*)) dmzo rhs v w g deldmz delz dmz z 27 xiold xi) 28 (type (f2cl-lib:integer4) mode msing)) 29 (let ((colloc-rho 30 (make-array 7 31 :element-type 'double-float 32 :displaced-to (colloc-part-0 *colloc-common-block*) 33 :displaced-index-offset 0)) 34 (colloc-coef 35 (make-array 49 36 :element-type 'double-float 37 :displaced-to (colloc-part-0 *colloc-common-block*) 38 :displaced-index-offset 7)) 39 (colord-m 40 (make-array 20 41 :element-type 'f2cl-lib:integer4 42 :displaced-to (colord-part-0 *colord-common-block*) 43 :displaced-index-offset 5)) 44 (colsid-zeta 45 (make-array 40 46 :element-type 'double-float 47 :displaced-to (colsid-part-0 *colsid-common-block*) 48 :displaced-index-offset 0)) 49 (colbas-acol 50 (make-array 196 51 :element-type 'double-float 52 :displaced-to (colbas-part-0 *colbas-common-block*) 53 :displaced-index-offset 28))) 54 (symbol-macrolet ((precis (aref (colout-part-0 *colout-common-block*) 0)) 55 (rho colloc-rho) 56 (coef colloc-coef) 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 (zeta colsid-zeta) 64 (aright (aref (colsid-part-0 *colsid-common-block*) 41)) 65 (izeta (aref (colsid-part-1 *colsid-common-block*) 0)) 66 (izsave (aref (colsid-part-1 *colsid-common-block*) 1)) 67 (n (aref (colapr-part-0 *colapr-common-block*) 0)) 68 (nold (aref (colapr-part-0 *colapr-common-block*) 1)) 69 (nz (aref (colapr-part-0 *colapr-common-block*) 3)) 70 (ndmz (aref (colapr-part-0 *colapr-common-block*) 4)) 71 (iguess (aref (colnln-part-0 *colnln-common-block*) 4)) 72 (acol colbas-acol)) 73 (f2cl-lib:with-multi-array-data 74 ((xi double-float xi-%data% xi-%offset%) 75 (xiold double-float xiold-%data% xiold-%offset%) 76 (z double-float z-%data% z-%offset%) 77 (dmz double-float dmz-%data% dmz-%offset%) 78 (delz double-float delz-%data% delz-%offset%) 79 (deldmz double-float deldmz-%data% deldmz-%offset%) 80 (g double-float g-%data% g-%offset%) 81 (w double-float w-%data% w-%offset%) 82 (v double-float v-%data% v-%offset%) 83 (rhs double-float rhs-%data% rhs-%offset%) 84 (dmzo double-float dmzo-%data% dmzo-%offset%) 85 (integs f2cl-lib:integer4 integs-%data% integs-%offset%) 86 (ipvtg f2cl-lib:integer4 ipvtg-%data% ipvtg-%offset%) 87 (ipvtw f2cl-lib:integer4 ipvtw-%data% ipvtw-%offset%)) 88 (prog ((izet 0) (iz 0) (value 0.0) (jj 0) (xcol 0.0) (hrho 0.0) (j 0) 89 (gval 0.0) (h 0.0) (xii 0.0) (l 0) (lw 0) (nrow 0) (ncol 0) 90 (iold 0) (lside 0) (iv 0) (iw 0) (ig 0) (irhs 0) (idmzo 0) 91 (idmz 0) (i 0) (m1 0) 92 (dummy (make-array 1 :element-type 'double-float)) 93 (at (make-array 28 :element-type 'double-float)) 94 (df (make-array 800 :element-type 'double-float)) 95 (dmval (make-array 20 :element-type 'double-float)) 96 (dgz (make-array 40 :element-type 'double-float)) 97 (f (make-array 40 :element-type 'double-float)) 98 (zval (make-array 40 :element-type 'double-float))) 99 (declare (type (array double-float (40)) zval f dgz) 100 (type (array double-float (20)) dmval) 101 (type (array double-float (800)) df) 102 (type (array double-float (28)) at) 103 (type (array double-float (1)) dummy) 104 (type double-float xii h gval hrho xcol value) 105 (type (f2cl-lib:integer4) m1 i idmz idmzo irhs ig iw iv 106 lside iold ncol nrow lw l j jj iz 107 izet)) 108 (setf m1 (f2cl-lib:int-add mode 1)) 109 (f2cl-lib:computed-goto (label10 label30 label30 label30 label310) 110 m1) 111 label10 112 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 113 ((> i mstar) nil) 114 (tagbody label20 (setf (f2cl-lib:fref zval (i) ((1 40))) 0.0))) 115 label30 116 (setf idmz 1) 117 (setf idmzo 1) 118 (setf irhs 1) 119 (setf ig 1) 120 (setf iw 1) 121 (setf iv 1) 122 (setf izeta 1) 123 (setf lside 0) 124 (setf iold 1) 125 (setf ncol (f2cl-lib:int-mul 2 mstar)) 126 (setf rnorm 0.0) 127 (if (> mode 1) (go label80)) 128 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 129 ((> i n) nil) 130 (tagbody 131 (setf (f2cl-lib:fref integs-%data% 132 (2 i) 133 ((1 3) (1 1)) 134 integs-%offset%) 135 ncol) 136 (if (< i n) (go label40)) 137 (setf (f2cl-lib:fref integs-%data% 138 (3 n) 139 ((1 3) (1 1)) 140 integs-%offset%) 141 ncol) 142 (setf lside mstar) 143 (go label60) 144 label40 145 (setf (f2cl-lib:fref integs-%data% 146 (3 i) 147 ((1 3) (1 1)) 148 integs-%offset%) 149 mstar) 150 label50 151 (if (= lside mstar) (go label60)) 152 (if 153 (>= (f2cl-lib:fref zeta ((f2cl-lib:int-add lside 1)) ((1 40))) 154 (+ (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%) 155 precis)) 156 (go label60)) 157 (setf lside (f2cl-lib:int-add lside 1)) 158 (go label50) 159 label60 160 (setf nrow (f2cl-lib:int-add mstar lside)) 161 label70 162 (setf (f2cl-lib:fref integs-%data% 163 (1 i) 164 ((1 3) (1 1)) 165 integs-%offset%) 166 nrow))) 167 label80 168 (if (= mode 2) (go label90)) 169 (setf lw (f2cl-lib:int-mul kd kd n)) 170 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 171 ((> l lw) nil) 172 (tagbody 173 label84 174 (setf (f2cl-lib:fref w-%data% (l) ((1 1)) w-%offset%) 0.0))) 175 label90 176 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 177 ((> i n) nil) 178 (tagbody 179 (setf xii (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 180 (setf h 181 (- 182 (f2cl-lib:fref xi-%data% 183 ((f2cl-lib:int-add i 1)) 184 ((1 1)) 185 xi-%offset%) 186 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))) 187 (setf nrow 188 (f2cl-lib:fref integs-%data% 189 (1 i) 190 ((1 3) (1 1)) 191 integs-%offset%)) 192 label100 193 (if (> izeta mstar) (go label140)) 194 (if (> (f2cl-lib:fref zeta (izeta) ((1 40))) (+ xii precis)) 195 (go label140)) 196 (if (= mode 0) (go label110)) 197 (if (/= iguess 1) (go label102)) 198 (multiple-value-bind (var-0 var-1 var-2) 199 (funcall guess xii zval dmval) 200 (declare (ignore var-1 var-2)) 201 (when var-0 202 (setf xii var-0))) 203 (go label110) 204 label102 205 (if (/= mode 1) (go label106)) 206 (multiple-value-bind 207 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 208 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 209 (approx iold xii zval at coef xiold nold z dmz k ncomp mmax m 210 mstar 2 dummy 0) 211 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 212 var-9 var-10 var-11 var-12 var-13 var-14 213 var-15 var-16)) 214 (setf iold var-0) 215 (setf xii var-1)) 216 (go label110) 217 label106 218 (multiple-value-bind 219 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 220 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 221 (approx i xii zval at dummy xi n z dmz k ncomp mmax m mstar 1 222 dummy 0) 223 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 224 var-9 var-10 var-11 var-12 var-13 var-14 225 var-15 var-16)) 226 (setf i var-0) 227 (setf xii var-1)) 228 label108 229 (if (= mode 3) (go label120)) 230 label110 231 (multiple-value-bind (var-0 var-1 var-2) 232 (funcall gsub izeta zval gval) 233 (declare (ignore var-1)) 234 (when var-0 235 (setf izeta var-0)) 236 (when var-2 237 (setf gval var-2))) 238 (setf (f2cl-lib:fref rhs-%data% 239 ((f2cl-lib:int-add ndmz izeta)) 240 ((1 1)) 241 rhs-%offset%) 242 (- gval)) 243 (setf rnorm (+ rnorm (expt gval 2))) 244 (if (= mode 2) (go label130)) 245 label120 246 (gderiv (f2cl-lib:array-slice g double-float (ig) ((1 1))) nrow 247 izeta zval dgz 1 dgsub) 248 label130 249 (setf izeta (f2cl-lib:int-add izeta 1)) 250 (go label100) 251 label140 252 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 253 ((> j k) nil) 254 (tagbody 255 (setf hrho (* h (f2cl-lib:fref rho (j) ((1 7))))) 256 (setf xcol (+ xii hrho)) 257 (if (= mode 0) (go label200)) 258 (if (/= iguess 1) (go label160)) 259 (multiple-value-bind (var-0 var-1 var-2) 260 (funcall guess 261 xcol 262 zval 263 (f2cl-lib:array-slice dmzo 264 double-float 265 (irhs) 266 ((1 1)))) 267 (declare (ignore var-1 var-2)) 268 (when var-0 269 (setf xcol var-0))) 270 (go label170) 271 label160 272 (if (/= mode 1) (go label190)) 273 (multiple-value-bind 274 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 275 var-9 var-10 var-11 var-12 var-13 var-14 var-15 276 var-16) 277 (approx iold xcol zval at coef xiold nold z dmz k ncomp 278 mmax m mstar 2 279 (f2cl-lib:array-slice dmzo double-float (irhs) ((1 1))) 280 1) 281 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 282 var-9 var-10 var-11 var-12 var-13 var-14 283 var-15 var-16)) 284 (setf iold var-0) 285 (setf xcol var-1)) 286 label170 287 (multiple-value-bind (var-0 var-1 var-2) 288 (funcall fsub xcol zval f) 289 (declare (ignore var-1 var-2)) 290 (when var-0 291 (setf xcol var-0))) 292 (f2cl-lib:fdo (jj 1 (f2cl-lib:int-add jj 1)) 293 ((> jj ncomp) nil) 294 (tagbody 295 (setf value 296 (- 297 (f2cl-lib:fref dmzo-%data% 298 (irhs) 299 ((1 1)) 300 dmzo-%offset%) 301 (f2cl-lib:fref f (jj) ((1 40))))) 302 (setf (f2cl-lib:fref rhs-%data% 303 (irhs) 304 ((1 1)) 305 rhs-%offset%) 306 (- value)) 307 (setf rnorm (+ rnorm (expt value 2))) 308 (setf irhs (f2cl-lib:int-add irhs 1)) 309 label180)) 310 (go label210) 311 label190 312 (multiple-value-bind 313 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 314 var-9 var-10 var-11 var-12 var-13 var-14 var-15 315 var-16) 316 (approx i xcol zval 317 (f2cl-lib:array-slice acol 318 double-float 319 (1 j) 320 ((1 28) (1 7))) 321 coef xi n z dmz k ncomp mmax m mstar 4 dummy 0) 322 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 323 var-9 var-10 var-11 var-12 var-13 var-14 324 var-15 var-16)) 325 (setf i var-0) 326 (setf xcol var-1)) 327 (if (= mode 3) (go label210)) 328 (multiple-value-bind (var-0 var-1 var-2) 329 (funcall fsub xcol zval f) 330 (declare (ignore var-1 var-2)) 331 (when var-0 332 (setf xcol var-0))) 333 (f2cl-lib:fdo (jj 1 (f2cl-lib:int-add jj 1)) 334 ((> jj ncomp) nil) 335 (tagbody 336 (setf value 337 (- 338 (f2cl-lib:fref dmz-%data% 339 (irhs) 340 ((1 1)) 341 dmz-%offset%) 342 (f2cl-lib:fref f (jj) ((1 40))))) 343 (setf (f2cl-lib:fref rhs-%data% 344 (irhs) 345 ((1 1)) 346 rhs-%offset%) 347 (- value)) 348 (setf rnorm (+ rnorm (expt value 2))) 349 (setf irhs (f2cl-lib:int-add irhs 1)) 350 label195)) 351 (go label220) 352 label200 353 (multiple-value-bind (var-0 var-1 var-2) 354 (funcall fsub 355 xcol 356 zval 357 (f2cl-lib:array-slice rhs 358 double-float 359 (irhs) 360 ((1 1)))) 361 (declare (ignore var-1 var-2)) 362 (when var-0 363 (setf xcol var-0))) 364 (setf irhs (f2cl-lib:int-add irhs ncomp)) 365 label210 366 (multiple-value-bind 367 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 368 var-9 var-10 var-11 var-12 var-13) 369 (vwblok xcol hrho j 370 (f2cl-lib:array-slice w double-float (iw) ((1 1))) 371 (f2cl-lib:array-slice v double-float (iv) ((1 1))) 372 (f2cl-lib:array-slice ipvtw 373 f2cl-lib:integer4 374 (idmz) 375 ((1 1))) 376 kd zval df 377 (f2cl-lib:array-slice acol 378 double-float 379 (1 j) 380 ((1 28) (1 7))) 381 (f2cl-lib:array-slice dmzo double-float (idmzo) ((1 1))) 382 ncomp dfsub msing) 383 (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 384 var-8 var-9 var-10 var-11 var-12)) 385 (setf xcol var-0) 386 (setf msing var-13)) 387 (if (/= msing 0) (go end_label)) 388 label220)) 389 (if (/= mode 2) 390 (gblock h (f2cl-lib:array-slice g double-float (ig) ((1 1))) 391 nrow izeta 392 (f2cl-lib:array-slice w double-float (iw) ((1 1))) 393 (f2cl-lib:array-slice v double-float (iv) ((1 1))) kd dummy 394 (f2cl-lib:array-slice deldmz double-float (idmz) ((1 1))) 395 (f2cl-lib:array-slice ipvtw 396 f2cl-lib:integer4 397 (idmz) 398 ((1 1))) 399 1)) 400 (if (< i n) (go label280)) 401 (setf izsave izeta) 402 label240 403 (if (> izeta mstar) (go label290)) 404 (if (= mode 0) (go label250)) 405 (if (/= iguess 1) (go label245)) 406 (multiple-value-bind (var-0 var-1 var-2) 407 (funcall guess aright zval dmval) 408 (declare (ignore var-1 var-2)) 409 (when var-0 410 (setf aright var-0))) 411 (go label250) 412 label245 413 (if (/= mode 1) (go label246)) 414 (multiple-value-bind 415 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 416 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 417 (approx (f2cl-lib:int-add nold 1) aright zval at coef xiold 418 nold z dmz k ncomp mmax m mstar 1 dummy 0) 419 (declare (ignore var-0 var-2 var-3 var-4 var-5 var-6 var-7 420 var-8 var-9 var-10 var-11 var-12 var-13 var-14 421 var-15 var-16)) 422 (setf aright var-1)) 423 (go label250) 424 label246 425 (multiple-value-bind 426 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 427 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 428 (approx (f2cl-lib:int-add n 1) aright zval at coef xi n z dmz 429 k ncomp mmax m mstar 1 dummy 0) 430 (declare (ignore var-0 var-2 var-3 var-4 var-5 var-6 var-7 431 var-8 var-9 var-10 var-11 var-12 var-13 var-14 432 var-15 var-16)) 433 (setf aright var-1)) 434 label248 435 (if (= mode 3) (go label260)) 436 label250 437 (multiple-value-bind (var-0 var-1 var-2) 438 (funcall gsub izeta zval gval) 439 (declare (ignore var-1)) 440 (when var-0 441 (setf izeta var-0)) 442 (when var-2 443 (setf gval var-2))) 444 (setf (f2cl-lib:fref rhs-%data% 445 ((f2cl-lib:int-add ndmz izeta)) 446 ((1 1)) 447 rhs-%offset%) 448 (- gval)) 449 (setf rnorm (+ rnorm (expt gval 2))) 450 (if (= mode 2) (go label270)) 451 label260 452 (gderiv (f2cl-lib:array-slice g double-float (ig) ((1 1))) nrow 453 (f2cl-lib:int-add izeta mstar) zval dgz 2 dgsub) 454 label270 455 (setf izeta (f2cl-lib:int-add izeta 1)) 456 (go label240) 457 label280 458 (setf ig (f2cl-lib:int-add ig (f2cl-lib:int-mul nrow ncol))) 459 (setf iv (f2cl-lib:int-add iv (f2cl-lib:int-mul kd mstar))) 460 (setf iw (f2cl-lib:int-add iw (f2cl-lib:int-mul kd kd))) 461 (setf idmz (f2cl-lib:int-add idmz kd)) 462 (if (= mode 1) (setf idmzo (f2cl-lib:int-add idmzo kd))) 463 label290)) 464 (if (or (= mode 0) (= mode 3)) (go label300)) 465 (setf rnorm 466 (f2cl-lib:dsqrt 467 (/ rnorm (f2cl-lib:dfloat (f2cl-lib:int-add nz ndmz))))) 468 (if (/= mode 2) (go label300)) 469 (go end_label) 470 label300 471 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) 472 (fcblok g integs n ipvtg df msing) 473 (declare (ignore var-0 var-1 var-2 var-3 var-4)) 474 (setf msing var-5)) 475 (setf msing (f2cl-lib:int-sub msing)) 476 (if (/= msing 0) (go end_label)) 477 label310 478 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 479 ((> l ndmz) nil) 480 (tagbody 481 (setf (f2cl-lib:fref deldmz-%data% (l) ((1 1)) deldmz-%offset%) 482 (f2cl-lib:fref rhs-%data% (l) ((1 1)) rhs-%offset%)) 483 label311)) 484 (setf iz 1) 485 (setf idmz 1) 486 (setf iw 1) 487 (setf izet 1) 488 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 489 ((> i n) nil) 490 (tagbody 491 (setf nrow 492 (f2cl-lib:fref integs-%data% 493 (1 i) 494 ((1 3) (1 1)) 495 integs-%offset%)) 496 (setf izeta (f2cl-lib:int-sub (f2cl-lib:int-add nrow 1) mstar)) 497 (if (= i n) (setf izeta izsave)) 498 label322 499 (if (= izet izeta) (go label324)) 500 (setf (f2cl-lib:fref delz-%data% 501 ((f2cl-lib:int-add (f2cl-lib:int-sub iz 1) 502 izet)) 503 ((1 1)) 504 delz-%offset%) 505 (f2cl-lib:fref rhs-%data% 506 ((f2cl-lib:int-add ndmz izet)) 507 ((1 1)) 508 rhs-%offset%)) 509 (setf izet (f2cl-lib:int-add izet 1)) 510 (go label322) 511 label324 512 (setf h 513 (- 514 (f2cl-lib:fref xi-%data% 515 ((f2cl-lib:int-add i 1)) 516 ((1 1)) 517 xi-%offset%) 518 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))) 519 (gblock h (f2cl-lib:array-slice g double-float (1) ((1 1))) nrow 520 izeta (f2cl-lib:array-slice w double-float (iw) ((1 1))) 521 (f2cl-lib:array-slice v double-float (1) ((1 1))) kd 522 (f2cl-lib:array-slice delz double-float (iz) ((1 1))) 523 (f2cl-lib:array-slice deldmz double-float (idmz) ((1 1))) 524 (f2cl-lib:array-slice ipvtw f2cl-lib:integer4 (idmz) ((1 1))) 2) 525 (setf iz (f2cl-lib:int-add iz mstar)) 526 (setf idmz (f2cl-lib:int-add idmz kd)) 527 (setf iw (f2cl-lib:int-add iw (f2cl-lib:int-mul kd kd))) 528 (if (< i n) (go label320)) 529 label326 530 (if (> izet mstar) (go label320)) 531 (setf (f2cl-lib:fref delz-%data% 532 ((f2cl-lib:int-add (f2cl-lib:int-sub iz 1) 533 izet)) 534 ((1 1)) 535 delz-%offset%) 536 (f2cl-lib:fref rhs-%data% 537 ((f2cl-lib:int-add ndmz izet)) 538 ((1 1)) 539 rhs-%offset%)) 540 (setf izet (f2cl-lib:int-add izet 1)) 541 (go label326) 542 label320)) 543 (sbblok g integs n ipvtg delz) 544 (dmzsol kd mstar n v delz deldmz) 545 (if (/= mode 1) (go end_label)) 546 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 547 ((> l ndmz) nil) 548 (tagbody 549 (setf (f2cl-lib:fref dmz-%data% (l) ((1 1)) dmz-%offset%) 550 (f2cl-lib:fref dmzo-%data% (l) ((1 1)) dmzo-%offset%)) 551 label321)) 552 (setf iz 1) 553 (setf idmz 1) 554 (setf iw 1) 555 (setf izet 1) 556 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 557 ((> i n) nil) 558 (tagbody 559 (setf nrow 560 (f2cl-lib:fref integs-%data% 561 (1 i) 562 ((1 3) (1 1)) 563 integs-%offset%)) 564 (setf izeta (f2cl-lib:int-sub (f2cl-lib:int-add nrow 1) mstar)) 565 (if (= i n) (setf izeta izsave)) 566 label330 567 (if (= izet izeta) (go label340)) 568 (setf (f2cl-lib:fref z-%data% 569 ((f2cl-lib:int-add (f2cl-lib:int-sub iz 1) 570 izet)) 571 ((1 1)) 572 z-%offset%) 573 (f2cl-lib:fref dgz (izet) ((1 40)))) 574 (setf izet (f2cl-lib:int-add izet 1)) 575 (go label330) 576 label340 577 (setf h 578 (- 579 (f2cl-lib:fref xi-%data% 580 ((f2cl-lib:int-add i 1)) 581 ((1 1)) 582 xi-%offset%) 583 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))) 584 (gblock h (f2cl-lib:array-slice g double-float (1) ((1 1))) nrow 585 izeta (f2cl-lib:array-slice w double-float (iw) ((1 1))) df kd 586 (f2cl-lib:array-slice z double-float (iz) ((1 1))) 587 (f2cl-lib:array-slice dmz double-float (idmz) ((1 1))) 588 (f2cl-lib:array-slice ipvtw f2cl-lib:integer4 (idmz) ((1 1))) 2) 589 (setf iz (f2cl-lib:int-add iz mstar)) 590 (setf idmz (f2cl-lib:int-add idmz kd)) 591 (setf iw (f2cl-lib:int-add iw (f2cl-lib:int-mul kd kd))) 592 (if (< i n) (go label350)) 593 label342 594 (if (> izet mstar) (go label350)) 595 (setf (f2cl-lib:fref z-%data% 596 ((f2cl-lib:int-add (f2cl-lib:int-sub iz 1) 597 izet)) 598 ((1 1)) 599 z-%offset%) 600 (f2cl-lib:fref dgz (izet) ((1 40)))) 601 (setf izet (f2cl-lib:int-add izet 1)) 602 (go label342) 603 label350)) 604 (sbblok g integs n ipvtg z) 605 (dmzsol kd mstar n v z dmz) 606 (go end_label) 607 end_label 608 (return 609 (values msing 610 nil 611 nil 612 nil 613 nil 614 nil 615 nil 616 nil 617 nil 618 nil 619 nil 620 nil 621 nil 622 nil 623 nil 624 rnorm 625 nil 626 nil 627 nil 628 nil 629 nil 630 nil))))))) 631 632(in-package #-gcl #:cl-user #+gcl "CL-USER") 633#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 634(eval-when (:load-toplevel :compile-toplevel :execute) 635 (setf (gethash 'fortran-to-lisp::lsyslv 636 fortran-to-lisp::*f2cl-function-info*) 637 (fortran-to-lisp::make-f2cl-finfo 638 :arg-types '((fortran-to-lisp::integer4) (array double-float (1)) 639 (array double-float (1)) (array double-float (1)) 640 (array double-float (1)) (array double-float (1)) 641 (array double-float (1)) (array double-float (1)) 642 (array double-float (1)) (array double-float (1)) 643 (array double-float (1)) (array double-float (1)) 644 (array fortran-to-lisp::integer4 (3)) 645 (array fortran-to-lisp::integer4 (1)) 646 (array fortran-to-lisp::integer4 (1)) double-float 647 (fortran-to-lisp::integer4) t t t t t) 648 :return-values '(fortran-to-lisp::msing nil nil nil nil nil nil nil 649 nil nil nil nil nil nil nil fortran-to-lisp::rnorm 650 nil nil nil nil nil nil) 651 :calls '(fortran-to-lisp::dmzsol fortran-to-lisp::sbblok 652 fortran-to-lisp::fcblok fortran-to-lisp::gblock 653 fortran-to-lisp::vwblok fortran-to-lisp::gderiv 654 fortran-to-lisp::approx)))) 655 656