share/colnew/lisp/vwblok.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 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