share/hompack/lisp/polsys.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   3 ;;;  "f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   4 ;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   5 ;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   6 ;;;  "f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v 1409c1352feb 2013/03/24 20:44:50 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2020-04 (21D 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 "HOMPACK")
  18
  19
  20 (defun polsys
  21        (n numt coef kdeg iflg1 iflg2 epsbig epssml sspar numrr nn mmaxt ttotdg
  22         lenwk leniwk lambda$ roots arclen nfe wk iwk)
  23   (declare (type (array double-float (*)) sspar)
  24            (type (double-float) epssml epsbig)
  25            (type (array double-float (*)) wk arclen roots lambda$ coef)
  26            (type (array f2cl-lib:integer4 (*)) iwk nfe iflg2 kdeg numt)
  27            (type (f2cl-lib:integer4) leniwk lenwk ttotdg mmaxt nn numrr iflg1
  28                                      n))
  29   (f2cl-lib:with-multi-array-data
  30       ((numt f2cl-lib:integer4 numt-%data% numt-%offset%)
  31        (kdeg f2cl-lib:integer4 kdeg-%data% kdeg-%offset%)
  32        (iflg2 f2cl-lib:integer4 iflg2-%data% iflg2-%offset%)
  33        (nfe f2cl-lib:integer4 nfe-%data% nfe-%offset%)
  34        (iwk f2cl-lib:integer4 iwk-%data% iwk-%offset%)
  35        (coef double-float coef-%data% coef-%offset%)
  36        (lambda$ double-float lambda$-%data% lambda$-%offset%)
  37        (roots double-float roots-%data% roots-%offset%)
  38        (arclen double-float arclen-%data% arclen-%offset%)
  39        (wk double-float wk-%data% wk-%offset%)
  40        (sspar double-float sspar-%data% sspar-%offset%))
  41     (prog ((lwk (make-array 19 :element-type 'f2cl-lib:integer4))
  42            (liwk (make-array 4 :element-type 'f2cl-lib:integer4))
  43            (wkoff (make-array 19 :element-type 'f2cl-lib:integer4))
  44            (iwkoff (make-array 4 :element-type 'f2cl-lib:integer4)) (i 0)
  45            (ideg 0) (iideg 0) (j 0) (k 0) (l 0) (leniww 0) (lenwkk 0) (maxt 0)
  46            (n2 0) (totdg 0))
  47       (declare (type (array f2cl-lib:integer4 (19)) wkoff lwk)
  48                (type (array f2cl-lib:integer4 (4)) liwk iwkoff)
  49                (type (f2cl-lib:integer4) totdg n2 maxt lenwkk leniww l k j
  50                                          iideg ideg i))
  51       (cond
  52         ((< nn n)
  53          (setf iflg1 -1)
  54          (go end_label)))
  55       (setf maxt 0)
  56       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  57                     ((> j n) nil)
  58         (tagbody
  59           (if (< maxt (f2cl-lib:fref numt-%data% (j) ((1 nn)) numt-%offset%))
  60               (setf maxt
  61                       (f2cl-lib:fref numt-%data% (j) ((1 nn)) numt-%offset%)))
  62          label50))
  63       (cond
  64         ((< mmaxt maxt)
  65          (setf iflg1 -2)
  66          (go end_label)))
  67       (setf totdg 1)
  68       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  69                     ((> j n) nil)
  70         (tagbody
  71           (setf ideg 0)
  72           (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  73                         ((> k (f2cl-lib:fref numt (j) ((1 nn)))) nil)
  74             (tagbody
  75               (setf iideg 0)
  76               (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
  77                             ((> l n) nil)
  78                 (tagbody
  79                   (setf iideg
  80                           (f2cl-lib:int-add iideg
  81                                             (f2cl-lib:fref kdeg-%data%
  82                                                            (j l k)
  83                                                            ((1 nn)
  84                                                             (1
  85                                                              (f2cl-lib:int-add
  86                                                               nn
  87                                                               1))
  88                                                             (1 mmaxt))
  89                                                            kdeg-%offset%)))
  90                  label60))
  91               (if (> iideg ideg) (setf ideg iideg))
  92              label70))
  93           (setf totdg (f2cl-lib:int-mul totdg ideg))
  94          label80))
  95       (cond
  96         ((< ttotdg totdg)
  97          (setf iflg1 -3)
  98          (go end_label)))
  99       (setf lenwkk
 100               (f2cl-lib:int-add 21
 101                                 (f2cl-lib:int-mul 61 n)
 102                                 (f2cl-lib:int-mul 10 (expt n 2))
 103                                 (f2cl-lib:int-mul 7 n mmaxt)
 104                                 (f2cl-lib:int-mul 4 (expt n 2) mmaxt)))
 105       (cond
 106         ((< lenwk lenwkk)
 107          (setf iflg1 -4)
 108          (go end_label)))
 109       (setf leniww
 110               (f2cl-lib:int-add 43
 111                                 (f2cl-lib:int-mul 7 n)
 112                                 (f2cl-lib:int-mul n
 113                                                   (f2cl-lib:int-add n 1)
 114                                                   mmaxt)))
 115       (cond
 116         ((< leniwk leniww)
 117          (setf iflg1 -5)
 118          (go end_label)))
 119       (cond
 120         ((and (/= iflg1 0) (/= iflg1 1) (/= iflg1 10) (/= iflg1 11))
 121          (setf iflg1 -6)
 122          (go end_label)))
 123       (setf n2 (f2cl-lib:int-mul 2 n))
 124       (setf (f2cl-lib:fref lwk (1) ((1 19))) n2)
 125       (setf (f2cl-lib:fref lwk (2) ((1 19))) n2)
 126       (setf (f2cl-lib:fref lwk (3) ((1 19))) n2)
 127       (setf (f2cl-lib:fref lwk (4) ((1 19))) n)
 128       (setf (f2cl-lib:fref lwk (5) ((1 19)))
 129               (f2cl-lib:int-mul 2 (f2cl-lib:int-add n 1)))
 130       (setf (f2cl-lib:fref lwk (6) ((1 19))) (f2cl-lib:int-add n2 1))
 131       (setf (f2cl-lib:fref lwk (7) ((1 19))) (f2cl-lib:int-add n2 1))
 132       (setf (f2cl-lib:fref lwk (8) ((1 19))) (f2cl-lib:int-add n2 1))
 133       (setf (f2cl-lib:fref lwk (9) ((1 19))) (f2cl-lib:int-add n2 1))
 134       (setf (f2cl-lib:fref lwk (10) ((1 19)))
 135               (f2cl-lib:int-mul n2 (f2cl-lib:int-add n2 2)))
 136       (setf (f2cl-lib:fref lwk (11) ((1 19))) n2)
 137       (setf (f2cl-lib:fref lwk (12) ((1 19))) (f2cl-lib:int-add n2 1))
 138       (setf (f2cl-lib:fref lwk (13) ((1 19))) (f2cl-lib:int-add n2 1))
 139       (setf (f2cl-lib:fref lwk (14) ((1 19))) (f2cl-lib:int-add n2 1))
 140       (setf (f2cl-lib:fref lwk (15) ((1 19))) (f2cl-lib:int-add n2 1))
 141       (setf (f2cl-lib:fref lwk (16) ((1 19))) (f2cl-lib:int-add n2 1))
 142       (setf (f2cl-lib:fref lwk (17) ((1 19))) 8)
 143       (setf (f2cl-lib:fref lwk (18) ((1 19)))
 144               (f2cl-lib:int-add 2
 145                                 (f2cl-lib:int-mul 28 n)
 146                                 (f2cl-lib:int-mul 6 (expt n 2))
 147                                 (f2cl-lib:int-mul 7 n mmaxt)
 148                                 (f2cl-lib:int-mul 4 (expt n 2) mmaxt)))
 149       (setf (f2cl-lib:fref liwk (1) ((1 4))) n)
 150       (setf (f2cl-lib:fref liwk (2) ((1 4))) n)
 151       (setf (f2cl-lib:fref liwk (3) ((1 4)))
 152               (f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 1))
 153       (setf (f2cl-lib:fref liwk (4) ((1 4)))
 154               (f2cl-lib:int-add 42
 155                                 (f2cl-lib:int-mul 2 n)
 156                                 (f2cl-lib:int-mul n
 157                                                   (f2cl-lib:int-add n 1)
 158                                                   mmaxt)))
 159       (setf (f2cl-lib:fref wkoff (1) ((1 19))) 1)
 160       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
 161                     ((> i 18) nil)
 162         (tagbody
 163           (setf (f2cl-lib:fref wkoff (i) ((1 19)))
 164                   (f2cl-lib:int-add
 165                    (f2cl-lib:fref wkoff ((f2cl-lib:int-sub i 1)) ((1 19)))
 166                    (f2cl-lib:fref lwk ((f2cl-lib:int-sub i 1)) ((1 19)))))
 167          label100))
 168       (setf (f2cl-lib:fref iwkoff (1) ((1 4))) 1)
 169       (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
 170                     ((> i 4) nil)
 171         (tagbody
 172           (setf (f2cl-lib:fref iwkoff (i) ((1 4)))
 173                   (f2cl-lib:int-add
 174                    (f2cl-lib:fref iwkoff ((f2cl-lib:int-sub i 1)) ((1 4)))
 175                    (f2cl-lib:fref liwk ((f2cl-lib:int-sub i 1)) ((1 4)))))
 176          label200))
 177       (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 178                     ((> j 8) nil)
 179         (tagbody
 180           (setf (f2cl-lib:fref wk-%data%
 181                                ((f2cl-lib:int-add
 182                                  (f2cl-lib:fref wkoff (17) ((1 19)))
 183                                  (f2cl-lib:int-sub j 1)))
 184                                ((1 lenwk))
 185                                wk-%offset%)
 186                   (f2cl-lib:fref sspar-%data% (j) ((1 8)) sspar-%offset%))
 187          label300))
 188       (multiple-value-bind
 189             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 190              var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18 var-19
 191              var-20 var-21 var-22 var-23 var-24 var-25 var-26 var-27 var-28
 192              var-29 var-30 var-31 var-32 var-33 var-34 var-35 var-36 var-37
 193              var-38)
 194           (polyp n numt coef kdeg iflg1 iflg2 epsbig epssml numrr nn mmaxt
 195            ttotdg lambda$ roots arclen nfe totdg
 196            (f2cl-lib:array-slice wk-%data%
 197                                  double-float
 198                                  ((f2cl-lib:fref wkoff (1) ((1 19))))
 199                                  ((1 lenwk))
 200                                  wk-%offset%)
 201            (f2cl-lib:array-slice wk-%data%
 202                                  double-float
 203                                  ((f2cl-lib:fref wkoff (2) ((1 19))))
 204                                  ((1 lenwk))
 205                                  wk-%offset%)
 206            (f2cl-lib:array-slice wk-%data%
 207                                  double-float
 208                                  ((f2cl-lib:fref wkoff (3) ((1 19))))
 209                                  ((1 lenwk))
 210                                  wk-%offset%)
 211            (f2cl-lib:array-slice wk-%data%
 212                                  double-float
 213                                  ((f2cl-lib:fref wkoff (4) ((1 19))))
 214                                  ((1 lenwk))
 215                                  wk-%offset%)
 216            (f2cl-lib:array-slice wk-%data%
 217                                  double-float
 218                                  ((f2cl-lib:fref wkoff (5) ((1 19))))
 219                                  ((1 lenwk))
 220                                  wk-%offset%)
 221            (f2cl-lib:array-slice wk-%data%
 222                                  double-float
 223                                  ((f2cl-lib:fref wkoff (6) ((1 19))))
 224                                  ((1 lenwk))
 225                                  wk-%offset%)
 226            (f2cl-lib:array-slice wk-%data%
 227                                  double-float
 228                                  ((f2cl-lib:fref wkoff (7) ((1 19))))
 229                                  ((1 lenwk))
 230                                  wk-%offset%)
 231            (f2cl-lib:array-slice wk-%data%
 232                                  double-float
 233                                  ((f2cl-lib:fref wkoff (8) ((1 19))))
 234                                  ((1 lenwk))
 235                                  wk-%offset%)
 236            (f2cl-lib:array-slice wk-%data%
 237                                  double-float
 238                                  ((f2cl-lib:fref wkoff (9) ((1 19))))
 239                                  ((1 lenwk))
 240                                  wk-%offset%)
 241            (f2cl-lib:array-slice wk-%data%
 242                                  double-float
 243                                  ((f2cl-lib:fref wkoff (10) ((1 19))))
 244                                  ((1 lenwk))
 245                                  wk-%offset%)
 246            (f2cl-lib:array-slice wk-%data%
 247                                  double-float
 248                                  ((f2cl-lib:fref wkoff (11) ((1 19))))
 249                                  ((1 lenwk))
 250                                  wk-%offset%)
 251            (f2cl-lib:array-slice wk-%data%
 252                                  double-float
 253                                  ((f2cl-lib:fref wkoff (12) ((1 19))))
 254                                  ((1 lenwk))
 255                                  wk-%offset%)
 256            (f2cl-lib:array-slice wk-%data%
 257                                  double-float
 258                                  ((f2cl-lib:fref wkoff (13) ((1 19))))
 259                                  ((1 lenwk))
 260                                  wk-%offset%)
 261            (f2cl-lib:array-slice wk-%data%
 262                                  double-float
 263                                  ((f2cl-lib:fref wkoff (14) ((1 19))))
 264                                  ((1 lenwk))
 265                                  wk-%offset%)
 266            (f2cl-lib:array-slice wk-%data%
 267                                  double-float
 268                                  ((f2cl-lib:fref wkoff (15) ((1 19))))
 269                                  ((1 lenwk))
 270                                  wk-%offset%)
 271            (f2cl-lib:array-slice wk-%data%
 272                                  double-float
 273                                  ((f2cl-lib:fref wkoff (16) ((1 19))))
 274                                  ((1 lenwk))
 275                                  wk-%offset%)
 276            (f2cl-lib:array-slice wk-%data%
 277                                  double-float
 278                                  ((f2cl-lib:fref wkoff (17) ((1 19))))
 279                                  ((1 lenwk))
 280                                  wk-%offset%)
 281            (f2cl-lib:array-slice wk-%data%
 282                                  double-float
 283                                  ((f2cl-lib:fref wkoff (18) ((1 19))))
 284                                  ((1 lenwk))
 285                                  wk-%offset%)
 286            (f2cl-lib:array-slice iwk-%data%
 287                                  f2cl-lib:integer4
 288                                  ((f2cl-lib:fref iwkoff (1) ((1 4))))
 289                                  ((1 leniwk))
 290                                  iwk-%offset%)
 291            (f2cl-lib:array-slice iwk-%data%
 292                                  f2cl-lib:integer4
 293                                  ((f2cl-lib:fref iwkoff (2) ((1 4))))
 294                                  ((1 leniwk))
 295                                  iwk-%offset%)
 296            (f2cl-lib:array-slice iwk-%data%
 297                                  f2cl-lib:integer4
 298                                  ((f2cl-lib:fref iwkoff (3) ((1 4))))
 299                                  ((1 leniwk))
 300                                  iwk-%offset%)
 301            (f2cl-lib:array-slice iwk-%data%
 302                                  f2cl-lib:integer4
 303                                  ((f2cl-lib:fref iwkoff (4) ((1 4))))
 304                                  ((1 leniwk))
 305                                  iwk-%offset%))
 306         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
 307                          var-10 var-11 var-12 var-13 var-14 var-15 var-16
 308                          var-17 var-18 var-19 var-20 var-21 var-22 var-23
 309                          var-24 var-25 var-26 var-27 var-28 var-29 var-30
 310                          var-31 var-32 var-33 var-34 var-35 var-36 var-37
 311                          var-38))
 312         (setf numrr var-8))
 313       (go end_label)
 314      end_label
 315       (return
 316        (values nil
 317                nil
 318                nil
 319                nil
 320                iflg1
 321                nil
 322                nil
 323                nil
 324                nil
 325                numrr
 326                nil
 327                nil
 328                nil
 329                nil
 330                nil
 331                nil
 332                nil
 333                nil
 334                nil
 335                nil
 336                nil)))))
 337
 338 (in-package #:cl-user)
 339 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 340 (eval-when (:load-toplevel :compile-toplevel :execute)
 341   (setf (gethash 'fortran-to-lisp::polsys
 342                  fortran-to-lisp::*f2cl-function-info*)
 343           (fortran-to-lisp::make-f2cl-finfo
 344            :arg-types '((fortran-to-lisp::integer4)
 345                         (array fortran-to-lisp::integer4 (*))
 346                         (array double-float (*))
 347                         (array fortran-to-lisp::integer4 (*))
 348                         (fortran-to-lisp::integer4)
 349                         (array fortran-to-lisp::integer4 (*)) (double-float)
 350                         (double-float) (array double-float (*))
 351                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 352                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 353                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 354                         (array double-float (*)) (array double-float (*))
 355                         (array double-float (*))
 356                         (array fortran-to-lisp::integer4 (*))
 357                         (array double-float (*))
 358                         (array fortran-to-lisp::integer4 (*)))
 359            :return-values '(nil nil nil nil fortran-to-lisp::iflg1 nil nil nil
 360                             nil fortran-to-lisp::numrr nil nil nil nil nil nil
 361                             nil nil nil nil nil)
 362            :calls '(fortran-to-lisp::polyp))))
 363