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 skale (n mstar kd z xi scale dscale) 21 (declare (type (array double-float (*)) xi) 22 (type (array double-float (*)) dscale scale z) 23 (type (f2cl-lib:integer4) kd mstar n)) 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 (symbol-macrolet ((ncomp (aref (colord-part-0 *colord-common-block*) 1)) 30 (mmax (aref (colord-part-0 *colord-common-block*) 4)) 31 (m colord-m)) 32 (f2cl-lib:with-multi-array-data 33 ((z double-float z-%data% z-%offset%) 34 (scale double-float scale-%data% scale-%offset%) 35 (dscale double-float dscale-%data% dscale-%offset%) 36 (xi double-float xi-%data% xi-%offset%)) 37 (prog ((np1 0) (idmz 0) (mj 0) (scal 0.0) (icomp 0) (l 0) (h 0.0) 38 (iz 0) (j 0) (basm (make-array 5 :element-type 'double-float))) 39 (declare (type (array double-float (5)) basm) 40 (type double-float h scal) 41 (type (f2cl-lib:integer4) j iz l icomp mj idmz np1)) 42 (setf (f2cl-lib:fref basm (1) ((1 5))) 1.0) 43 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 44 ((> j n) nil) 45 (tagbody 46 (setf iz 1) 47 (setf h 48 (- 49 (f2cl-lib:fref xi-%data% 50 ((f2cl-lib:int-add j 1)) 51 ((1 1)) 52 xi-%offset%) 53 (f2cl-lib:fref xi-%data% (j) ((1 1)) xi-%offset%))) 54 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 55 ((> l mmax) nil) 56 (tagbody 57 (setf (f2cl-lib:fref basm ((f2cl-lib:int-add l 1)) ((1 5))) 58 (/ (* (f2cl-lib:fref basm (l) ((1 5))) h) 59 (f2cl-lib:dfloat l))) 60 label10)) 61 (f2cl-lib:fdo (icomp 1 (f2cl-lib:int-add icomp 1)) 62 ((> icomp ncomp) nil) 63 (tagbody 64 (setf scal 65 (+ 66 (* 67 (+ 68 (f2cl-lib:dabs 69 (f2cl-lib:fref z-%data% 70 (iz j) 71 ((1 mstar) (1 1)) 72 z-%offset%)) 73 (f2cl-lib:dabs 74 (f2cl-lib:fref z-%data% 75 (iz (f2cl-lib:int-add j 1)) 76 ((1 mstar) (1 1)) 77 z-%offset%))) 78 0.5) 79 1.0)) 80 (setf mj (f2cl-lib:fref m (icomp) ((1 20)))) 81 (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) 82 ((> l mj) nil) 83 (tagbody 84 (setf (f2cl-lib:fref scale-%data% 85 (iz j) 86 ((1 mstar) (1 1)) 87 scale-%offset%) 88 (/ (f2cl-lib:fref basm (l) ((1 5))) scal)) 89 (setf iz (f2cl-lib:int-add iz 1)) 90 label20)) 91 (setf scal 92 (/ 93 (f2cl-lib:fref basm 94 ((f2cl-lib:int-add mj 1)) 95 ((1 5))) 96 scal)) 97 (f2cl-lib:fdo (idmz icomp (f2cl-lib:int-add idmz ncomp)) 98 ((> idmz kd) nil) 99 (tagbody 100 (setf (f2cl-lib:fref dscale-%data% 101 (idmz j) 102 ((1 kd) (1 1)) 103 dscale-%offset%) 104 scal) 105 label30)) 106 label40)) 107 label50)) 108 (setf np1 (f2cl-lib:int-add n 1)) 109 (f2cl-lib:fdo (iz 1 (f2cl-lib:int-add iz 1)) 110 ((> iz mstar) nil) 111 (tagbody 112 (setf (f2cl-lib:fref scale-%data% 113 (iz np1) 114 ((1 mstar) (1 1)) 115 scale-%offset%) 116 (f2cl-lib:fref scale-%data% 117 (iz n) 118 ((1 mstar) (1 1)) 119 scale-%offset%)) 120 label60)) 121 (go end_label) 122 end_label 123 (return (values nil nil nil nil nil nil nil))))))) 124 125(in-package #-gcl #:cl-user #+gcl "CL-USER") 126#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 127(eval-when (:load-toplevel :compile-toplevel :execute) 128 (setf (gethash 'fortran-to-lisp::skale fortran-to-lisp::*f2cl-function-info*) 129 (fortran-to-lisp::make-f2cl-finfo 130 :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 131 (fortran-to-lisp::integer4) (array double-float (*)) 132 (array double-float (1)) (array double-float (*)) 133 (array double-float (*))) 134 :return-values '(nil nil nil nil nil nil nil) 135 :calls 'nil))) 136 137