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 errchk (xi z dmz valstr ifin) 21 (declare (type (f2cl-lib:integer4) ifin) 22 (type (array double-float (*)) valstr dmz z xi)) 23 (let ((colord-m 24 (make-array 20 25 :element-type 'f2cl-lib:integer4 26 :displaced-to (colord-part-0 *colord-common-block*) 27 :displaced-index-offset 5)) 28 (colbas-asave 29 (make-array 112 30 :element-type 'double-float 31 :displaced-to (colbas-part-0 *colbas-common-block*) 32 :displaced-index-offset 224)) 33 (colest-wgterr 34 (make-array 40 35 :element-type 'double-float 36 :displaced-to (colest-part-0 *colest-common-block*) 37 :displaced-index-offset 80)) 38 (colest-tolin 39 (make-array 40 40 :element-type 'double-float 41 :displaced-to (colest-part-0 *colest-common-block*) 42 :displaced-index-offset 120)) 43 (colest-ltol 44 (make-array 40 45 :element-type 'f2cl-lib:integer4 46 :displaced-to (colest-part-1 *colest-common-block*) 47 :displaced-index-offset 40))) 48 (symbol-macrolet ((iout (aref (colout-part-1 *colout-common-block*) 0)) 49 (iprint (aref (colout-part-1 *colout-common-block*) 1)) 50 (k (aref (colord-part-0 *colord-common-block*) 0)) 51 (ncomp (aref (colord-part-0 *colord-common-block*) 1)) 52 (mstar (aref (colord-part-0 *colord-common-block*) 2)) 53 (mmax (aref (colord-part-0 *colord-common-block*) 4)) 54 (m colord-m) 55 (n (aref (colapr-part-0 *colapr-common-block*) 0)) 56 (mshflg (aref (colmsh-part-0 *colmsh-common-block*) 0)) 57 (asave colbas-asave) 58 (wgterr colest-wgterr) 59 (tolin colest-tolin) 60 (ltol colest-ltol) 61 (ntol (aref (colest-part-1 *colest-common-block*) 80))) 62 (f2cl-lib:with-multi-array-data 63 ((xi double-float xi-%data% xi-%offset%) 64 (z double-float z-%data% z-%offset%) 65 (dmz double-float dmz-%data% dmz-%offset%) 66 (valstr double-float valstr-%data% valstr-%offset%)) 67 (prog ((mj 0) (lj 0) (ltjz 0) (ltolj 0) (l 0) (x 0.0) (kstore 0) 68 (knew 0) (i 0) (iback 0) (j 0) 69 (dummy (make-array 1 :element-type 'double-float)) 70 (errest (make-array 40 :element-type 'double-float)) 71 (err (make-array 40 :element-type 'double-float))) 72 (declare (type (array double-float (40)) err errest) 73 (type (array double-float (1)) dummy) 74 (type double-float x) 75 (type (f2cl-lib:integer4) j iback i knew kstore l ltolj ltjz 76 lj mj)) 77 (setf ifin 1) 78 (setf mshflg 1) 79 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 80 ((> j mstar) nil) 81 (tagbody label10 (setf (f2cl-lib:fref errest (j) ((1 40))) 0.0))) 82 (f2cl-lib:fdo (iback 1 (f2cl-lib:int-add iback 1)) 83 ((> iback n) nil) 84 (tagbody 85 (setf i (f2cl-lib:int-sub (f2cl-lib:int-add n 1) iback)) 86 (setf knew 87 (f2cl-lib:int-add 88 (f2cl-lib:int-mul 89 (f2cl-lib:int-add 90 (f2cl-lib:int-mul 4 (f2cl-lib:int-sub i 1)) 91 2) 92 mstar) 93 1)) 94 (setf kstore 95 (f2cl-lib:int-add 96 (f2cl-lib:int-mul 97 (f2cl-lib:int-add 98 (f2cl-lib:int-mul 2 (f2cl-lib:int-sub i 1)) 99 1) 100 mstar) 101 1)) 102 (setf x 103 (+ (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%) 104 (/ 105 (* 106 (- 107 (f2cl-lib:fref xi-%data% 108 ((f2cl-lib:int-add i 1)) 109 ((1 1)) 110 xi-%offset%) 111 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 112 2.0) 113 3.0))) 114 (multiple-value-bind 115 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 116 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 117 (approx i x 118 (f2cl-lib:array-slice valstr double-float (knew) ((1 1))) 119 (f2cl-lib:array-slice asave 120 double-float 121 (1 3) 122 ((1 28) (1 4))) 123 dummy xi n z dmz k ncomp mmax m mstar 4 dummy 0) 124 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 125 var-9 var-10 var-11 var-12 var-13 var-14 126 var-15 var-16)) 127 (setf i var-0) 128 (setf x var-1)) 129 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 130 ((> l mstar) nil) 131 (tagbody 132 (setf (f2cl-lib:fref err (l) ((1 40))) 133 (* (f2cl-lib:fref wgterr (l) ((1 40))) 134 (f2cl-lib:dabs 135 (- 136 (f2cl-lib:fref valstr-%data% 137 (knew) 138 ((1 1)) 139 valstr-%offset%) 140 (f2cl-lib:fref valstr-%data% 141 (kstore) 142 ((1 1)) 143 valstr-%offset%))))) 144 (setf knew (f2cl-lib:int-add knew 1)) 145 (setf kstore (f2cl-lib:int-add kstore 1)) 146 label20)) 147 (setf knew 148 (f2cl-lib:int-add 149 (f2cl-lib:int-mul 150 (f2cl-lib:int-add 151 (f2cl-lib:int-mul 4 (f2cl-lib:int-sub i 1)) 152 1) 153 mstar) 154 1)) 155 (setf kstore 156 (f2cl-lib:int-add 157 (f2cl-lib:int-mul 2 (f2cl-lib:int-sub i 1) mstar) 158 1)) 159 (setf x 160 (+ (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%) 161 (/ 162 (- 163 (f2cl-lib:fref xi-%data% 164 ((f2cl-lib:int-add i 1)) 165 ((1 1)) 166 xi-%offset%) 167 (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)) 168 3.0))) 169 (multiple-value-bind 170 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 171 var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16) 172 (approx i x 173 (f2cl-lib:array-slice valstr double-float (knew) ((1 1))) 174 (f2cl-lib:array-slice asave 175 double-float 176 (1 2) 177 ((1 28) (1 4))) 178 dummy xi n z dmz k ncomp mmax m mstar 4 dummy 0) 179 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 180 var-9 var-10 var-11 var-12 var-13 var-14 181 var-15 var-16)) 182 (setf i var-0) 183 (setf x var-1)) 184 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 185 ((> l mstar) nil) 186 (tagbody 187 (setf (f2cl-lib:fref err (l) ((1 40))) 188 (+ (f2cl-lib:fref err (l) ((1 40))) 189 (* (f2cl-lib:fref wgterr (l) ((1 40))) 190 (f2cl-lib:dabs 191 (- 192 (f2cl-lib:fref valstr-%data% 193 (knew) 194 ((1 1)) 195 valstr-%offset%) 196 (f2cl-lib:fref valstr-%data% 197 (kstore) 198 ((1 1)) 199 valstr-%offset%)))))) 200 (setf knew (f2cl-lib:int-add knew 1)) 201 (setf kstore (f2cl-lib:int-add kstore 1)) 202 label30)) 203 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 204 ((> l mstar) nil) 205 (tagbody 206 (setf (f2cl-lib:fref errest (l) ((1 40))) 207 (f2cl-lib:dmax1 (f2cl-lib:fref errest (l) ((1 40))) 208 (f2cl-lib:fref err (l) ((1 40))))) 209 label40)) 210 (if (= ifin 0) (go label60)) 211 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 212 ((> j ntol) nil) 213 (tagbody 214 (setf ltolj (f2cl-lib:fref ltol (j) ((1 40)))) 215 (setf ltjz 216 (f2cl-lib:int-add ltolj 217 (f2cl-lib:int-mul 218 (f2cl-lib:int-sub i 1) 219 mstar))) 220 (if 221 (> (f2cl-lib:fref err (ltolj) ((1 40))) 222 (* (f2cl-lib:fref tolin (j) ((1 40))) 223 (+ 224 (f2cl-lib:dabs 225 (f2cl-lib:fref z-%data% (ltjz) ((1 1)) z-%offset%)) 226 1.0))) 227 (setf ifin 0)) 228 label50)) 229 label60)) 230 (if (>= iprint 0) (go end_label)) 231 (f2cl-lib:fformat iout ("~%" " THE ESTIMATED ERRORS ARE," "~%")) 232 (setf lj 1) 233 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 234 ((> j ncomp) nil) 235 (tagbody 236 (setf mj 237 (f2cl-lib:int-add (f2cl-lib:int-sub lj 1) 238 (f2cl-lib:fref m (j) ((1 20))))) 239 (f2cl-lib:fformat iout 240 (" U(" 1 (("~2D")) ") -" 4 241 (("~12,4,2,0,'*,,'DE")) "~%") 242 j 243 (do ((l lj (f2cl-lib:int-add l 1)) 244 (%ret nil)) 245 ((> l mj) (nreverse %ret)) 246 (declare (type f2cl-lib:integer4 l)) 247 (push (f2cl-lib:fref errest (l) ((1 40))) 248 %ret))) 249 (setf lj (f2cl-lib:int-add mj 1)) 250 label70)) 251 (go end_label) 252 end_label 253 (return (values nil nil nil nil ifin))))))) 254 255(in-package #-gcl #:cl-user #+gcl "CL-USER") 256#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 257(eval-when (:load-toplevel :compile-toplevel :execute) 258 (setf (gethash 'fortran-to-lisp::errchk 259 fortran-to-lisp::*f2cl-function-info*) 260 (fortran-to-lisp::make-f2cl-finfo 261 :arg-types '((array double-float (1)) (array double-float (1)) 262 (array double-float (1)) (array double-float (1)) 263 (fortran-to-lisp::integer4)) 264 :return-values '(nil nil nil nil fortran-to-lisp::ifin) 265 :calls '(fortran-to-lisp::approx)))) 266 267