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 vwblok (xcol hrho jj wi vi ipvtw kd zval df acol dmzo ncomp dfsub msing) 21 (declare (type (array double-float (*)) acol) 22 (type (array double-float (*)) dmzo zval) 23 (type (array f2cl-lib:integer4 (*)) ipvtw) 24 (type (array double-float (*)) df vi wi) 25 (type (f2cl-lib:integer4) msing ncomp kd jj) 26 (type double-float hrho xcol)) 27 (let ((colord-m 28 (make-array 20 29 :element-type 'f2cl-lib:integer4 30 :displaced-to (colord-part-0 *colord-common-block*) 31 :displaced-index-offset 5))) 32 (symbol-macrolet ((k (aref (colord-part-0 *colord-common-block*) 0)) 33 (mstar (aref (colord-part-0 *colord-common-block*) 2)) 34 (mmax (aref (colord-part-0 *colord-common-block*) 4)) 35 (m colord-m) 36 (nonlin (aref (colnln-part-0 *colnln-common-block*) 0)) 37 (iter (aref (colnln-part-0 *colnln-common-block*) 1))) 38 (f2cl-lib:with-multi-array-data 39 ((wi double-float wi-%data% wi-%offset%) 40 (vi double-float vi-%data% vi-%offset%) 41 (df double-float df-%data% df-%offset%) 42 (ipvtw f2cl-lib:integer4 ipvtw-%data% ipvtw-%offset%) 43 (zval double-float zval-%data% zval-%offset%) 44 (dmzo double-float dmzo-%data% dmzo-%offset%) 45 (acol double-float acol-%data% acol-%offset%)) 46 (prog ((bl 0.0) (jdf 0) (ll 0) (lp1 0) (iw 0) (ajl 0.0) (jw 0) (jv 0) 47 (mj 0) (jcomp 0) (jn 0) (i2 0) (i1 0) (i0 0) (ir 0) (jcol 0) 48 (j 0) (l 0) (fact 0.0) (id 0) 49 (basm (make-array 5 :element-type 'double-float)) 50 (ha (make-array 28 :element-type 'double-float))) 51 (declare (type (array double-float (28)) ha) 52 (type (array double-float (5)) basm) 53 (type (f2cl-lib:integer4) id l j jcol ir i0 i1 i2 jn jcomp 54 mj jv jw iw lp1 ll jdf) 55 (type double-float fact ajl bl)) 56 (if (> jj 1) (go label30)) 57 (f2cl-lib:fdo (id 1 (f2cl-lib:int-add id 1)) 58 ((> id kd) nil) 59 (tagbody 60 (setf (f2cl-lib:fref wi-%data% 61 (id id) 62 ((1 kd) (1 1)) 63 wi-%offset%) 64 1.0) 65 label10)) 66 label30 67 (setf fact 1.0) 68 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 69 ((> l mmax) nil) 70 (tagbody 71 (setf fact (/ (* fact hrho) (f2cl-lib:dfloat l))) 72 (setf (f2cl-lib:fref basm (l) ((1 5))) fact) 73 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 74 ((> j k) nil) 75 (tagbody 76 (setf (f2cl-lib:fref ha (j l) ((1 7) (1 4))) 77 (* fact 78 (f2cl-lib:fref acol-%data% 79 (j l) 80 ((1 7) (1 4)) 81 acol-%offset%))) 82 label150)))) 83 label150 84 (f2cl-lib:fdo (jcol 1 (f2cl-lib:int-add jcol 1)) 85 ((> jcol mstar) nil) 86 (tagbody 87 (f2cl-lib:fdo (ir 1 (f2cl-lib:int-add ir 1)) 88 ((> ir ncomp) nil) 89 (tagbody 90 (setf (f2cl-lib:fref df-%data% 91 (ir jcol) 92 ((1 ncomp) (1 1)) 93 df-%offset%) 94 0.0))))) 95 label40 96 (multiple-value-bind (var-0 var-1 var-2) 97 (funcall dfsub xcol zval df) 98 (declare (ignore var-1 var-2)) 99 (when var-0 100 (setf xcol var-0))) 101 (setf i0 (f2cl-lib:int-mul (f2cl-lib:int-sub jj 1) ncomp)) 102 (setf i1 (f2cl-lib:int-add i0 1)) 103 (setf i2 (f2cl-lib:int-add i0 ncomp)) 104 (if (or (= nonlin 0) (> iter 0)) (go label60)) 105 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 106 ((> j mstar) nil) 107 (tagbody 108 (setf fact 109 (- 110 (f2cl-lib:fref zval-%data% (j) ((1 1)) zval-%offset%))) 111 (f2cl-lib:fdo (id 1 (f2cl-lib:int-add id 1)) 112 ((> id ncomp) nil) 113 (tagbody 114 (setf (f2cl-lib:fref dmzo-%data% 115 ((f2cl-lib:int-add i0 id)) 116 ((1 1)) 117 dmzo-%offset%) 118 (+ 119 (f2cl-lib:fref dmzo-%data% 120 ((f2cl-lib:int-add i0 id)) 121 ((1 1)) 122 dmzo-%offset%) 123 (* fact 124 (f2cl-lib:fref df-%data% 125 (id j) 126 ((1 ncomp) (1 1)) 127 df-%offset%)))) 128 label50)))) 129 label50 130 label60 131 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 132 ((> j mstar) nil) 133 (tagbody 134 (f2cl-lib:fdo (id 1 (f2cl-lib:int-add id 1)) 135 ((> id ncomp) nil) 136 (tagbody 137 (setf (f2cl-lib:fref vi-%data% 138 ((f2cl-lib:int-add i0 id) j) 139 ((1 kd) (1 1)) 140 vi-%offset%) 141 (f2cl-lib:fref df-%data% 142 (id j) 143 ((1 ncomp) (1 1)) 144 df-%offset%)) 145 label70)))) 146 label70 147 (setf jn 1) 148 (f2cl-lib:fdo (jcomp 1 (f2cl-lib:int-add jcomp 1)) 149 ((> jcomp ncomp) nil) 150 (tagbody 151 (setf mj (f2cl-lib:fref m (jcomp) ((1 20)))) 152 (setf jn (f2cl-lib:int-add jn mj)) 153 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 154 ((> l mj) nil) 155 (tagbody 156 (setf jv (f2cl-lib:int-sub jn l)) 157 (setf jw jcomp) 158 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 159 ((> j k) nil) 160 (tagbody 161 (setf ajl (- (f2cl-lib:fref ha (j l) ((1 7) (1 4))))) 162 (f2cl-lib:fdo (iw i1 (f2cl-lib:int-add iw 1)) 163 ((> iw i2) nil) 164 (tagbody 165 (setf (f2cl-lib:fref wi-%data% 166 (iw jw) 167 ((1 kd) (1 1)) 168 wi-%offset%) 169 (+ 170 (f2cl-lib:fref wi-%data% 171 (iw jw) 172 ((1 kd) (1 1)) 173 wi-%offset%) 174 (* ajl 175 (f2cl-lib:fref vi-%data% 176 (iw jv) 177 ((1 kd) (1 1)) 178 vi-%offset%)))) 179 label80)) 180 label90 181 (setf jw (f2cl-lib:int-add jw ncomp)))) 182 (setf lp1 (f2cl-lib:int-add l 1)) 183 (if (= l mj) (go label130)) 184 (f2cl-lib:fdo (ll lp1 (f2cl-lib:int-add ll 1)) 185 ((> ll mj) nil) 186 (tagbody 187 (setf jdf (f2cl-lib:int-sub jn ll)) 188 (setf bl 189 (f2cl-lib:fref basm 190 ((f2cl-lib:int-sub ll l)) 191 ((1 5)))) 192 (f2cl-lib:fdo (iw i1 (f2cl-lib:int-add iw 1)) 193 ((> iw i2) nil) 194 (tagbody 195 (setf (f2cl-lib:fref vi-%data% 196 (iw jv) 197 ((1 kd) (1 1)) 198 vi-%offset%) 199 (+ 200 (f2cl-lib:fref vi-%data% 201 (iw jv) 202 ((1 kd) (1 1)) 203 vi-%offset%) 204 (* bl 205 (f2cl-lib:fref vi-%data% 206 (iw jdf) 207 ((1 kd) (1 1)) 208 vi-%offset%)))) 209 label100)) 210 label110)) 211 label130)) 212 label140)) 213 (if (< jj k) (go end_label)) 214 (setf msing 0) 215 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) 216 (dgefa wi kd kd ipvtw msing) 217 (declare (ignore var-0 var-1 var-2 var-3)) 218 (setf msing var-4)) 219 (if (/= msing 0) (go end_label)) 220 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 221 ((> j mstar) nil) 222 (tagbody 223 (dgesl wi kd kd ipvtw 224 (f2cl-lib:array-slice vi double-float (1 j) ((1 kd) (1 1))) 0) 225 label250)) 226 (go end_label) 227 end_label 228 (return 229 (values xcol 230 nil 231 nil 232 nil 233 nil 234 nil 235 nil 236 nil 237 nil 238 nil 239 nil 240 nil 241 nil 242 msing))))))) 243 244(in-package #-gcl #:cl-user #+gcl "CL-USER") 245#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 246(eval-when (:load-toplevel :compile-toplevel :execute) 247 (setf (gethash 'fortran-to-lisp::vwblok 248 fortran-to-lisp::*f2cl-function-info*) 249 (fortran-to-lisp::make-f2cl-finfo 250 :arg-types '(double-float double-float (fortran-to-lisp::integer4) 251 (array double-float (*)) (array double-float (*)) 252 (array fortran-to-lisp::integer4 (1)) 253 (fortran-to-lisp::integer4) (array double-float (1)) 254 (array double-float (*)) (array double-float (28)) 255 (array double-float (1)) (fortran-to-lisp::integer4) t 256 (fortran-to-lisp::integer4)) 257 :return-values '(fortran-to-lisp::xcol nil nil nil nil nil nil nil 258 nil nil nil nil nil fortran-to-lisp::msing) 259 :calls '(fortran-to-lisp::dgesl fortran-to-lisp::dgefa)))) 260 261