share/colnew/lisp/skale.lisp

   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