share/colnew/lisp/colnew.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 (labels ((multi-entry-colnew
  21              (%name% ncomp m aleft aright zeta ipar ltol tol fixpnt ispace
  22               fspace iflag fsub dfsub gsub dgsub guess)
  23            (declare (type (array double-float (*)) fspace fixpnt tol zeta)
  24                     (type double-float aright aleft)
  25                     (type (array f2cl-lib:integer4 (*)) ispace ltol ipar m)
  26                     (type (f2cl-lib:integer4) iflag ncomp))
  27            (let ((colloc-rho
  28                   (make-array 7
  29                               :element-type 'double-float
  30                               :displaced-to (colloc-part-0
  31                                              *colloc-common-block*)
  32                               :displaced-index-offset 0))
  33                  (colloc-coef
  34                   (make-array 49
  35                               :element-type 'double-float
  36                               :displaced-to (colloc-part-0
  37                                              *colloc-common-block*)
  38                               :displaced-index-offset 7))
  39                  (colord-mt
  40                   (make-array 20
  41                               :element-type 'f2cl-lib:integer4
  42                               :displaced-to (colord-part-0
  43                                              *colord-common-block*)
  44                               :displaced-index-offset 5))
  45                  (colsid-tzeta
  46                   (make-array 40
  47                               :element-type 'double-float
  48                               :displaced-to (colsid-part-0
  49                                              *colsid-common-block*)
  50                               :displaced-index-offset 0))
  51                  (colest-tolin
  52                   (make-array 40
  53                               :element-type 'double-float
  54                               :displaced-to (colest-part-0
  55                                              *colest-common-block*)
  56                               :displaced-index-offset 120))
  57                  (colest-lttol
  58                   (make-array 40
  59                               :element-type 'f2cl-lib:integer4
  60                               :displaced-to (colest-part-1
  61                                              *colest-common-block*)
  62                               :displaced-index-offset 40)))
  63              (symbol-macrolet ((precis
  64                                 (aref (colout-part-0 *colout-common-block*) 0))
  65                                (iout
  66                                 (aref (colout-part-1 *colout-common-block*) 0))
  67                                (iprint
  68                                 (aref (colout-part-1 *colout-common-block*) 1))
  69                                (rho colloc-rho)
  70                                (coef colloc-coef)
  71                                (k
  72                                 (aref (colord-part-0 *colord-common-block*) 0))
  73                                (nc
  74                                 (aref (colord-part-0 *colord-common-block*) 1))
  75                                (mstar
  76                                 (aref (colord-part-0 *colord-common-block*) 2))
  77                                (kd
  78                                 (aref (colord-part-0 *colord-common-block*) 3))
  79                                (mmax
  80                                 (aref (colord-part-0 *colord-common-block*) 4))
  81                                (mt colord-mt)
  82                                (n
  83                                 (aref (colapr-part-0 *colapr-common-block*) 0))
  84                                (nold
  85                                 (aref (colapr-part-0 *colapr-common-block*) 1))
  86                                (nmax
  87                                 (aref (colapr-part-0 *colapr-common-block*) 2))
  88                                (nz
  89                                 (aref (colapr-part-0 *colapr-common-block*) 3))
  90                                (ndmz
  91                                 (aref (colapr-part-0 *colapr-common-block*) 4))
  92                                (mshflg
  93                                 (aref (colmsh-part-0 *colmsh-common-block*) 0))
  94                                (mshnum
  95                                 (aref (colmsh-part-0 *colmsh-common-block*) 1))
  96                                (mshlmt
  97                                 (aref (colmsh-part-0 *colmsh-common-block*) 2))
  98                                (mshalt
  99                                 (aref (colmsh-part-0 *colmsh-common-block*) 3))
 100                                (tzeta colsid-tzeta)
 101                                (tleft
 102                                 (aref (colsid-part-0 *colsid-common-block*)
 103                                       40))
 104                                (tright
 105                                 (aref (colsid-part-0 *colsid-common-block*)
 106                                       41))
 107                                (nonlin
 108                                 (aref (colnln-part-0 *colnln-common-block*) 0))
 109                                (limit
 110                                 (aref (colnln-part-0 *colnln-common-block*) 2))
 111                                (icare
 112                                 (aref (colnln-part-0 *colnln-common-block*) 3))
 113                                (iguess
 114                                 (aref (colnln-part-0 *colnln-common-block*) 4))
 115                                (tolin colest-tolin)
 116                                (lttol colest-lttol)
 117                                (ntol
 118                                 (aref (colest-part-1 *colest-common-block*)
 119                                       80)))
 120                (f2cl-lib:with-multi-array-data
 121                    ((m f2cl-lib:integer4 m-%data% m-%offset%)
 122                     (ipar f2cl-lib:integer4 ipar-%data% ipar-%offset%)
 123                     (ltol f2cl-lib:integer4 ltol-%data% ltol-%offset%)
 124                     (ispace f2cl-lib:integer4 ispace-%data% ispace-%offset%)
 125                     (zeta double-float zeta-%data% zeta-%offset%)
 126                     (tol double-float tol-%data% tol-%offset%)
 127                     (fixpnt double-float fixpnt-%data% fixpnt-%offset%)
 128                     (fspace double-float fspace-%data% fspace-%offset%))
 129                  (prog ((ic 0) (k2 0) (idmz 0) (np1 0) (linteg 0) (lpvtw 0)
 130                         (lpvtg 0) (ldscl 0) (lscl 0) (laccum 0) (lslope 0)
 131                         (lvalst 0) (lrhs 0) (ldqdmz 0) (ldqz 0) (ldeldz 0)
 132                         (ldelz 0) (ldmz 0) (lz 0) (lv 0) (lw 0) (lxiold 0)
 133                         (lg 0) (lxi 0) (nmaxi 0) (nmaxf 0) (nsizef 0) (nfixf 0)
 134                         (nsizei 0) (nfixi 0) (ib 0) (nrec 0) (ip 0) (nfxpnt 0)
 135                         (ndimi 0) (ndimf 0) (iread 0) (i 0) (precp1 0.0)
 136                         (dummy (make-array 1 :element-type 'double-float)))
 137                    (declare (type (array double-float (1)) dummy)
 138                             (type double-float precp1)
 139                             (type (f2cl-lib:integer4) i iread ndimf ndimi
 140                                                       nfxpnt ip nrec ib nfixi
 141                                                       nsizei nfixf nsizef nmaxf
 142                                                       nmaxi lxi lg lxiold lw lv
 143                                                       lz ldmz ldelz ldeldz ldqz
 144                                                       ldqdmz lrhs lvalst lslope
 145                                                       laccum lscl ldscl lpvtg
 146                                                       lpvtw linteg np1 idmz k2
 147                                                       ic))
 148                    (if (eq %name% 'colsys) (go colsys))
 149                   colsys
 150                    (if
 151                     (<= (f2cl-lib:fref ipar-%data% (7) ((1 1)) ipar-%offset%)
 152                         0)
 153                     (f2cl-lib:fformat 6
 154                                       ("~%" "~%"
 155                                        " VERSION *COLNEW* OF COLSYS .    " "~%"
 156                                        "~%" "~%")))
 157                    (setf iout 6)
 158                    (setf precis 1.0)
 159                   label10
 160                    (setf precis (/ precis 2.0))
 161                    (setf precp1 (+ precis 1.0))
 162                    (if (> precp1 1.0) (go label10))
 163                    (setf precis (* precis 100.0))
 164                    (setf iflag -3)
 165                    (if (or (< ncomp 1) (> ncomp 20)) (go end_label))
 166                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 167                                  ((> i ncomp) nil)
 168                      (tagbody
 169                        (if
 170                         (or
 171                          (< (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%) 1)
 172                          (> (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%) 4))
 173                         (go end_label))
 174                       label20))
 175                    (setf nonlin
 176                            (f2cl-lib:fref ipar-%data%
 177                                           (1)
 178                                           ((1 1))
 179                                           ipar-%offset%))
 180                    (setf k
 181                            (f2cl-lib:fref ipar-%data%
 182                                           (2)
 183                                           ((1 1))
 184                                           ipar-%offset%))
 185                    (setf n
 186                            (f2cl-lib:fref ipar-%data%
 187                                           (3)
 188                                           ((1 1))
 189                                           ipar-%offset%))
 190                    (if (= n 0) (setf n 5))
 191                    (setf iread
 192                            (f2cl-lib:fref ipar-%data%
 193                                           (8)
 194                                           ((1 1))
 195                                           ipar-%offset%))
 196                    (setf iguess
 197                            (f2cl-lib:fref ipar-%data%
 198                                           (9)
 199                                           ((1 1))
 200                                           ipar-%offset%))
 201                    (if (and (= nonlin 0) (= iguess 1)) (setf iguess 0))
 202                    (if (and (>= iguess 2) (= iread 0)) (setf iread 1))
 203                    (setf icare
 204                            (f2cl-lib:fref ipar-%data%
 205                                           (10)
 206                                           ((1 1))
 207                                           ipar-%offset%))
 208                    (setf ntol
 209                            (f2cl-lib:fref ipar-%data%
 210                                           (4)
 211                                           ((1 1))
 212                                           ipar-%offset%))
 213                    (setf ndimf
 214                            (f2cl-lib:fref ipar-%data%
 215                                           (5)
 216                                           ((1 1))
 217                                           ipar-%offset%))
 218                    (setf ndimi
 219                            (f2cl-lib:fref ipar-%data%
 220                                           (6)
 221                                           ((1 1))
 222                                           ipar-%offset%))
 223                    (setf nfxpnt
 224                            (f2cl-lib:fref ipar-%data%
 225                                           (11)
 226                                           ((1 1))
 227                                           ipar-%offset%))
 228                    (setf iprint
 229                            (f2cl-lib:fref ipar-%data%
 230                                           (7)
 231                                           ((1 1))
 232                                           ipar-%offset%))
 233                    (setf mstar 0)
 234                    (setf mmax 0)
 235                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 236                                  ((> i ncomp) nil)
 237                      (tagbody
 238                        (setf mmax
 239                                (f2cl-lib:max0 mmax
 240                                               (f2cl-lib:fref m-%data%
 241                                                              (i)
 242                                                              ((1 1))
 243                                                              m-%offset%)))
 244                        (setf mstar
 245                                (f2cl-lib:int-add mstar
 246                                                  (f2cl-lib:fref m-%data%
 247                                                                 (i)
 248                                                                 ((1 1))
 249                                                                 m-%offset%)))
 250                        (setf (f2cl-lib:fref mt (i) ((1 20)))
 251                                (f2cl-lib:fref m-%data% (i) ((1 1)) m-%offset%))
 252                       label30))
 253                    (if (= k 0)
 254                        (setf k
 255                                (f2cl-lib:max0 (f2cl-lib:int-add mmax 1)
 256                                               (f2cl-lib:int-sub 5 mmax))))
 257                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 258                                  ((> i mstar) nil)
 259                      (tagbody
 260                       label40
 261                        (setf (f2cl-lib:fref tzeta (i) ((1 40)))
 262                                (f2cl-lib:fref zeta-%data%
 263                                               (i)
 264                                               ((1 1))
 265                                               zeta-%offset%))))
 266                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 267                                  ((> i ntol) nil)
 268                      (tagbody
 269                        (setf (f2cl-lib:fref lttol (i) ((1 40)))
 270                                (f2cl-lib:fref ltol-%data%
 271                                               (i)
 272                                               ((1 1))
 273                                               ltol-%offset%))
 274                       label50
 275                        (setf (f2cl-lib:fref tolin (i) ((1 40)))
 276                                (f2cl-lib:fref tol-%data%
 277                                               (i)
 278                                               ((1 1))
 279                                               tol-%offset%))))
 280                    (setf tleft aleft)
 281                    (setf tright aright)
 282                    (setf nc ncomp)
 283                    (setf kd (f2cl-lib:int-mul k ncomp))
 284                    (if (> iprint -1) (go label80))
 285                    (if (> nonlin 0) (go label60))
 286                    (f2cl-lib:fformat iout
 287                                      ("~%" "~%" "~%"
 288                                       " THE NUMBER OF (LINEAR) DIFF EQNS IS " 1
 289                                       (("~3D")) "~%" "~1@T" "THEIR ORDERS ARE"
 290                                       20 (("~3D")) "~%")
 291                                      ncomp
 292                                      (do ((ip 1 (f2cl-lib:int-add ip 1))
 293                                           (%ret nil))
 294                                          ((> ip ncomp) (nreverse %ret))
 295                                        (declare (type f2cl-lib:integer4 ip))
 296                                        (push
 297                                         (f2cl-lib:fref m-%data%
 298                                                        (ip)
 299                                                        ((1 1))
 300                                                        m-%offset%)
 301                                         %ret)))
 302                    (go label70)
 303                   label60
 304                    (f2cl-lib:fformat iout
 305                                      ("~%" "~%" "~%"
 306                                       " THE NUMBER OF (NONLINEAR) DIFF EQNS IS "
 307                                       1 (("~3D")) "~%" "~1@T"
 308                                       "THEIR ORDERS ARE" 20 (("~3D")) "~%")
 309                                      ncomp
 310                                      (do ((ip 1 (f2cl-lib:int-add ip 1))
 311                                           (%ret nil))
 312                                          ((> ip ncomp) (nreverse %ret))
 313                                        (declare (type f2cl-lib:integer4 ip))
 314                                        (push
 315                                         (f2cl-lib:fref m-%data%
 316                                                        (ip)
 317                                                        ((1 1))
 318                                                        m-%offset%)
 319                                         %ret)))
 320                   label70
 321                    (f2cl-lib:fformat iout
 322                                      (" SIDE CONDITION POINTS ZETA" 8
 323                                       (("~10,6,0,'*,F")) 4
 324                                       ("~%" "~27@T" 8 (("~10,6,0,'*,F"))) "~%")
 325                                      (do ((ip 1 (f2cl-lib:int-add ip 1))
 326                                           (%ret nil))
 327                                          ((> ip mstar) (nreverse %ret))
 328                                        (declare (type f2cl-lib:integer4 ip))
 329                                        (push
 330                                         (f2cl-lib:fref zeta-%data%
 331                                                        (ip)
 332                                                        ((1 1))
 333                                                        zeta-%offset%)
 334                                         %ret)))
 335                    (if (> nfxpnt 0)
 336                        (f2cl-lib:fformat iout
 337                                          (" THERE ARE" 1 (("~5D"))
 338                                           " FIXED POINTS IN THE MESH -" 10
 339                                           (6 (("~10,6,0,'*,F")) "~%") "~%")
 340                                          nfxpnt
 341                                          (do ((ip 1 (f2cl-lib:int-add ip 1))
 342                                               (%ret nil))
 343                                              ((> ip nfxpnt) (nreverse %ret))
 344                                            (declare (type f2cl-lib:integer4 ip))
 345                                            (push
 346                                             (f2cl-lib:fref fixpnt-%data%
 347                                                            (ip)
 348                                                            ((1 1))
 349                                                            fixpnt-%offset%)
 350                                             %ret))))
 351                    (f2cl-lib:fformat iout
 352                                      (" NUMBER OF COLLOC PTS PER INTERVAL IS" 1
 353                                       (("~3D")) "~%")
 354                                      k)
 355                    (f2cl-lib:fformat iout
 356                                      (" COMPONENTS OF Z REQUIRING TOLERANCES -"
 357                                       8 ("~7@T" 1 (("~2D")) "~1@T") 4
 358                                       ("~%" "~38@T" 8 (("~10D"))) "~%")
 359                                      (do ((ip 1 (f2cl-lib:int-add ip 1))
 360                                           (%ret nil))
 361                                          ((> ip ntol) (nreverse %ret))
 362                                        (declare (type f2cl-lib:integer4 ip))
 363                                        (push
 364                                         (f2cl-lib:fref ltol-%data%
 365                                                        (ip)
 366                                                        ((1 1))
 367                                                        ltol-%offset%)
 368                                         %ret)))
 369                    (f2cl-lib:fformat iout
 370                                      (" CORRESPONDING ERROR TOLERANCES -"
 371                                       "~6@T" 8 (("~10,2,2,0,'*,,'DE")) 4
 372                                       ("~%" "~39@T" 8 (("~10,2,2,0,'*,,'DE")))
 373                                       "~%")
 374                                      (do ((ip 1 (f2cl-lib:int-add ip 1))
 375                                           (%ret nil))
 376                                          ((> ip ntol) (nreverse %ret))
 377                                        (declare (type f2cl-lib:integer4 ip))
 378                                        (push
 379                                         (f2cl-lib:fref tol-%data%
 380                                                        (ip)
 381                                                        ((1 1))
 382                                                        tol-%offset%)
 383                                         %ret)))
 384                    (if (>= iguess 2)
 385                        (f2cl-lib:fformat iout
 386                                          (" INITIAL MESH(ES) AND Z,DMZ PROVIDED BY USER"
 387                                           "~%")))
 388                    (if (= iread 2)
 389                        (f2cl-lib:fformat iout
 390                                          (" NO ADAPTIVE MESH SELECTION" "~%")))
 391                   label80
 392                    (if (or (< k 0) (> k 7)) (go end_label))
 393                    (if (< n 0) (go end_label))
 394                    (if (or (< iread 0) (> iread 2)) (go end_label))
 395                    (if (or (< iguess 0) (> iguess 4)) (go end_label))
 396                    (if (or (< icare 0) (> icare 2)) (go end_label))
 397                    (if (or (< ntol 0) (> ntol mstar)) (go end_label))
 398                    (if (< nfxpnt 0) (go end_label))
 399                    (if (or (< iprint -1) (> iprint 1)) (go end_label))
 400                    (if (or (< mstar 0) (> mstar 40)) (go end_label))
 401                    (setf ip 1)
 402                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 403                                  ((> i mstar) nil)
 404                      (tagbody
 405                        (if
 406                         (or
 407                          (<
 408                           (f2cl-lib:dabs
 409                            (-
 410                             (f2cl-lib:fref zeta-%data%
 411                                            (i)
 412                                            ((1 1))
 413                                            zeta-%offset%)
 414                             aleft))
 415                           precis)
 416                          (<
 417                           (f2cl-lib:dabs
 418                            (-
 419                             (f2cl-lib:fref zeta-%data%
 420                                            (i)
 421                                            ((1 1))
 422                                            zeta-%offset%)
 423                             aright))
 424                           precis))
 425                         (go label100))
 426                       label90
 427                        (if (> ip nfxpnt) (go end_label))
 428                        (if
 429                         (<
 430                          (-
 431                           (f2cl-lib:fref zeta-%data% (i) ((1 1)) zeta-%offset%)
 432                           precis)
 433                          (f2cl-lib:fref fixpnt-%data%
 434                                         (ip)
 435                                         ((1 1))
 436                                         fixpnt-%offset%))
 437                         (go label95))
 438                        (setf ip (f2cl-lib:int-add ip 1))
 439                        (go label90)
 440                       label95
 441                        (if
 442                         (<
 443                          (+
 444                           (f2cl-lib:fref zeta-%data% (i) ((1 1)) zeta-%offset%)
 445                           precis)
 446                          (f2cl-lib:fref fixpnt-%data%
 447                                         (ip)
 448                                         ((1 1))
 449                                         fixpnt-%offset%))
 450                         (go end_label))
 451                       label100))
 452                    (setf mshlmt 3)
 453                    (setf mshflg 0)
 454                    (setf mshnum 1)
 455                    (setf mshalt 1)
 456                    (setf limit 40)
 457                    (setf nrec 0)
 458                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 459                                  ((> i mstar) nil)
 460                      (tagbody
 461                        (setf ib
 462                                (f2cl-lib:int-sub (f2cl-lib:int-add mstar 1) i))
 463                        (if
 464                         (>=
 465                          (f2cl-lib:fref zeta-%data% (ib) ((1 1)) zeta-%offset%)
 466                          aright)
 467                         (setf nrec i))
 468                       label110))
 469                    (setf nfixi mstar)
 470                    (setf nsizei (f2cl-lib:int-add 3 kd mstar))
 471                    (setf nfixf
 472                            (f2cl-lib:int-add
 473                             (f2cl-lib:int-mul nrec (f2cl-lib:int-mul 2 mstar))
 474                             (f2cl-lib:int-mul 5 mstar)
 475                             3))
 476                    (setf nsizef
 477                            (f2cl-lib:int-add 4
 478                                              (f2cl-lib:int-mul 3 mstar)
 479                                              (f2cl-lib:int-mul
 480                                               (f2cl-lib:int-add kd 5)
 481                                               (f2cl-lib:int-add kd mstar))
 482                                              (f2cl-lib:int-mul
 483                                               (f2cl-lib:int-sub
 484                                                (f2cl-lib:int-mul 2 mstar)
 485                                                nrec)
 486                                               2
 487                                               mstar)))
 488                    (setf nmaxf
 489                            (the f2cl-lib:integer4
 490                                 (truncate (- ndimf nfixf) nsizef)))
 491                    (setf nmaxi
 492                            (the f2cl-lib:integer4
 493                                 (truncate (- ndimi nfixi) nsizei)))
 494                    (if (< iprint 1)
 495                        (f2cl-lib:fformat iout
 496                                          (" THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN ("
 497                                           1 (("~4D")) " (ALLOWED FROM FSPACE),"
 498                                           1 (("~4D"))
 499                                           " (ALLOWED FROM ISPACE) )" "~%")
 500                                          nmaxf
 501                                          nmaxi))
 502                    (setf nmax (f2cl-lib:min0 nmaxf nmaxi))
 503                    (if (< nmax n) (go end_label))
 504                    (if (< nmax (f2cl-lib:int-add nfxpnt 1)) (go end_label))
 505                    (if
 506                     (and
 507                      (< nmax (f2cl-lib:int-add (f2cl-lib:int-mul 2 nfxpnt) 2))
 508                      (< iprint 1))
 509                     (f2cl-lib:fformat iout
 510                                       ("~%"
 511                                        " INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE"
 512                                        "~%")))
 513                    (setf lxi 1)
 514                    (setf lg (f2cl-lib:int-add lxi nmax 1))
 515                    (setf lxiold
 516                            (f2cl-lib:int-add lg
 517                                              (f2cl-lib:int-mul 2
 518                                                                mstar
 519                                                                (f2cl-lib:int-add
 520                                                                 (f2cl-lib:int-mul
 521                                                                  nmax
 522                                                                  (f2cl-lib:int-sub
 523                                                                   (f2cl-lib:int-mul
 524                                                                    2
 525                                                                    mstar)
 526                                                                   nrec))
 527                                                                 nrec))))
 528                    (setf lw (f2cl-lib:int-add lxiold nmax 1))
 529                    (setf lv
 530                            (f2cl-lib:int-add lw
 531                                              (f2cl-lib:int-mul (expt kd 2)
 532                                                                nmax)))
 533                    (setf lz
 534                            (f2cl-lib:int-add lv
 535                                              (f2cl-lib:int-mul mstar kd nmax)))
 536                    (setf ldmz
 537                            (f2cl-lib:int-add lz
 538                                              (f2cl-lib:int-mul mstar
 539                                                                (f2cl-lib:int-add
 540                                                                 nmax
 541                                                                 1))))
 542                    (setf ldelz
 543                            (f2cl-lib:int-add ldmz (f2cl-lib:int-mul kd nmax)))
 544                    (setf ldeldz
 545                            (f2cl-lib:int-add ldelz
 546                                              (f2cl-lib:int-mul mstar
 547                                                                (f2cl-lib:int-add
 548                                                                 nmax
 549                                                                 1))))
 550                    (setf ldqz
 551                            (f2cl-lib:int-add ldeldz
 552                                              (f2cl-lib:int-mul kd nmax)))
 553                    (setf ldqdmz
 554                            (f2cl-lib:int-add ldqz
 555                                              (f2cl-lib:int-mul mstar
 556                                                                (f2cl-lib:int-add
 557                                                                 nmax
 558                                                                 1))))
 559                    (setf lrhs
 560                            (f2cl-lib:int-add ldqdmz
 561                                              (f2cl-lib:int-mul kd nmax)))
 562                    (setf lvalst
 563                            (f2cl-lib:int-add lrhs
 564                                              (f2cl-lib:int-mul kd nmax)
 565                                              mstar))
 566                    (setf lslope
 567                            (f2cl-lib:int-add lvalst
 568                                              (f2cl-lib:int-mul 4 mstar nmax)))
 569                    (setf laccum (f2cl-lib:int-add lslope nmax))
 570                    (setf lscl (f2cl-lib:int-add laccum nmax 1))
 571                    (setf ldscl
 572                            (f2cl-lib:int-add lscl
 573                                              (f2cl-lib:int-mul mstar
 574                                                                (f2cl-lib:int-add
 575                                                                 nmax
 576                                                                 1))))
 577                    (setf lpvtg 1)
 578                    (setf lpvtw
 579                            (f2cl-lib:int-add lpvtg
 580                                              (f2cl-lib:int-mul mstar
 581                                                                (f2cl-lib:int-add
 582                                                                 nmax
 583                                                                 1))))
 584                    (setf linteg
 585                            (f2cl-lib:int-add lpvtw (f2cl-lib:int-mul kd nmax)))
 586                    (if (< iguess 2) (go label160))
 587                    (setf nold n)
 588                    (if (= iguess 4)
 589                        (setf nold
 590                                (f2cl-lib:fref ispace-%data%
 591                                               (1)
 592                                               ((1 1))
 593                                               ispace-%offset%)))
 594                    (setf nz (f2cl-lib:int-mul mstar (f2cl-lib:int-add nold 1)))
 595                    (setf ndmz (f2cl-lib:int-mul kd nold))
 596                    (setf np1 (f2cl-lib:int-add n 1))
 597                    (if (= iguess 4) (setf np1 (f2cl-lib:int-add np1 nold 1)))
 598                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 599                                  ((> i nz) nil)
 600                      (tagbody
 601                       label120
 602                        (setf (f2cl-lib:fref fspace-%data%
 603                                             ((f2cl-lib:int-sub
 604                                               (f2cl-lib:int-add lz i)
 605                                               1))
 606                                             ((1 1))
 607                                             fspace-%offset%)
 608                                (f2cl-lib:fref fspace-%data%
 609                                               ((f2cl-lib:int-add np1 i))
 610                                               ((1 1))
 611                                               fspace-%offset%))))
 612                    (setf idmz (f2cl-lib:int-add np1 nz))
 613                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 614                                  ((> i ndmz) nil)
 615                      (tagbody
 616                       label125
 617                        (setf (f2cl-lib:fref fspace-%data%
 618                                             ((f2cl-lib:int-sub
 619                                               (f2cl-lib:int-add ldmz i)
 620                                               1))
 621                                             ((1 1))
 622                                             fspace-%offset%)
 623                                (f2cl-lib:fref fspace-%data%
 624                                               ((f2cl-lib:int-add idmz i))
 625                                               ((1 1))
 626                                               fspace-%offset%))))
 627                    (setf np1 (f2cl-lib:int-add nold 1))
 628                    (if (= iguess 4) (go label140))
 629                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 630                                  ((> i np1) nil)
 631                      (tagbody
 632                       label130
 633                        (setf (f2cl-lib:fref fspace-%data%
 634                                             ((f2cl-lib:int-sub
 635                                               (f2cl-lib:int-add lxiold i)
 636                                               1))
 637                                             ((1 1))
 638                                             fspace-%offset%)
 639                                (f2cl-lib:fref fspace-%data%
 640                                               ((f2cl-lib:int-sub
 641                                                 (f2cl-lib:int-add lxi i)
 642                                                 1))
 643                                               ((1 1))
 644                                               fspace-%offset%))))
 645                    (go label160)
 646                   label140
 647                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 648                                  ((> i np1) nil)
 649                      (tagbody
 650                       label150
 651                        (setf (f2cl-lib:fref fspace-%data%
 652                                             ((f2cl-lib:int-sub
 653                                               (f2cl-lib:int-add lxiold i)
 654                                               1))
 655                                             ((1 1))
 656                                             fspace-%offset%)
 657                                (f2cl-lib:fref fspace-%data%
 658                                               ((f2cl-lib:int-add n 1 i))
 659                                               ((1 1))
 660                                               fspace-%offset%))))
 661                   label160
 662                    (consts k rho coef)
 663                    (newmsh (f2cl-lib:int-add 3 iread)
 664                     (f2cl-lib:array-slice fspace double-float (lxi) ((1 1)))
 665                     (f2cl-lib:array-slice fspace double-float (lxiold) ((1 1)))
 666                     dummy dummy dummy dummy dummy nfxpnt fixpnt)
 667                    (if (>= iguess 2) (go label230))
 668                    (setf np1 (f2cl-lib:int-add n 1))
 669                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 670                                  ((> i np1) nil)
 671                      (tagbody
 672                       label210
 673                        (setf (f2cl-lib:fref fspace-%data%
 674                                             ((f2cl-lib:int-sub
 675                                               (f2cl-lib:int-add i lxiold)
 676                                               1))
 677                                             ((1 1))
 678                                             fspace-%offset%)
 679                                (f2cl-lib:fref fspace-%data%
 680                                               ((f2cl-lib:int-sub
 681                                                 (f2cl-lib:int-add i lxi)
 682                                                 1))
 683                                               ((1 1))
 684                                               fspace-%offset%))))
 685                    (setf nold n)
 686                    (if (or (= nonlin 0) (= iguess 1)) (go label230))
 687                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 688                                  ((> i nz) nil)
 689                      (tagbody
 690                       label220
 691                        (setf (f2cl-lib:fref fspace-%data%
 692                                             ((f2cl-lib:int-add
 693                                               (f2cl-lib:int-sub lz 1)
 694                                               i))
 695                                             ((1 1))
 696                                             fspace-%offset%)
 697                                0.0)))
 698                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 699                                  ((> i ndmz) nil)
 700                      (tagbody
 701                       label225
 702                        (setf (f2cl-lib:fref fspace-%data%
 703                                             ((f2cl-lib:int-add
 704                                               (f2cl-lib:int-sub ldmz 1)
 705                                               i))
 706                                             ((1 1))
 707                                             fspace-%offset%)
 708                                0.0)))
 709                   label230
 710                    (if (>= iguess 2) (setf iguess 0))
 711                    (multiple-value-bind
 712                          (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 713                           var-9 var-10 var-11 var-12 var-13 var-14 var-15
 714                           var-16 var-17 var-18 var-19 var-20 var-21 var-22
 715                           var-23 var-24 var-25 var-26 var-27)
 716                        (contrl
 717                         (f2cl-lib:array-slice fspace
 718                                               double-float
 719                                               (lxi)
 720                                               ((1 1)))
 721                         (f2cl-lib:array-slice fspace
 722                                               double-float
 723                                               (lxiold)
 724                                               ((1 1)))
 725                         (f2cl-lib:array-slice fspace double-float (lz) ((1 1)))
 726                         (f2cl-lib:array-slice fspace
 727                                               double-float
 728                                               (ldmz)
 729                                               ((1 1)))
 730                         (f2cl-lib:array-slice fspace
 731                                               double-float
 732                                               (lrhs)
 733                                               ((1 1)))
 734                         (f2cl-lib:array-slice fspace
 735                                               double-float
 736                                               (ldelz)
 737                                               ((1 1)))
 738                         (f2cl-lib:array-slice fspace
 739                                               double-float
 740                                               (ldeldz)
 741                                               ((1 1)))
 742                         (f2cl-lib:array-slice fspace
 743                                               double-float
 744                                               (ldqz)
 745                                               ((1 1)))
 746                         (f2cl-lib:array-slice fspace
 747                                               double-float
 748                                               (ldqdmz)
 749                                               ((1 1)))
 750                         (f2cl-lib:array-slice fspace double-float (lg) ((1 1)))
 751                         (f2cl-lib:array-slice fspace double-float (lw) ((1 1)))
 752                         (f2cl-lib:array-slice fspace double-float (lv) ((1 1)))
 753                         (f2cl-lib:array-slice fspace
 754                                               double-float
 755                                               (lvalst)
 756                                               ((1 1)))
 757                         (f2cl-lib:array-slice fspace
 758                                               double-float
 759                                               (lslope)
 760                                               ((1 1)))
 761                         (f2cl-lib:array-slice fspace
 762                                               double-float
 763                                               (lscl)
 764                                               ((1 1)))
 765                         (f2cl-lib:array-slice fspace
 766                                               double-float
 767                                               (ldscl)
 768                                               ((1 1)))
 769                         (f2cl-lib:array-slice fspace
 770                                               double-float
 771                                               (laccum)
 772                                               ((1 1)))
 773                         (f2cl-lib:array-slice ispace
 774                                               f2cl-lib:integer4
 775                                               (lpvtg)
 776                                               ((1 1)))
 777                         (f2cl-lib:array-slice ispace
 778                                               f2cl-lib:integer4
 779                                               (linteg)
 780                                               ((1 1)))
 781                         (f2cl-lib:array-slice ispace
 782                                               f2cl-lib:integer4
 783                                               (lpvtw)
 784                                               ((1 1)))
 785                         nfxpnt fixpnt iflag fsub dfsub gsub dgsub guess)
 786                      (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6
 787                                       var-7 var-8 var-9 var-10 var-11 var-12
 788                                       var-13 var-14 var-15 var-16 var-17 var-18
 789                                       var-19 var-20 var-21 var-23 var-24 var-25
 790                                       var-26 var-27))
 791                      (setf iflag var-22))
 792                    (setf (f2cl-lib:fref ispace-%data%
 793                                         (1)
 794                                         ((1 1))
 795                                         ispace-%offset%)
 796                            n)
 797                    (setf (f2cl-lib:fref ispace-%data%
 798                                         (2)
 799                                         ((1 1))
 800                                         ispace-%offset%)
 801                            k)
 802                    (setf (f2cl-lib:fref ispace-%data%
 803                                         (3)
 804                                         ((1 1))
 805                                         ispace-%offset%)
 806                            ncomp)
 807                    (setf (f2cl-lib:fref ispace-%data%
 808                                         (4)
 809                                         ((1 1))
 810                                         ispace-%offset%)
 811                            mstar)
 812                    (setf (f2cl-lib:fref ispace-%data%
 813                                         (5)
 814                                         ((1 1))
 815                                         ispace-%offset%)
 816                            mmax)
 817                    (setf (f2cl-lib:fref ispace-%data%
 818                                         (6)
 819                                         ((1 1))
 820                                         ispace-%offset%)
 821                            (f2cl-lib:int-add nz ndmz n 2))
 822                    (setf k2 (f2cl-lib:int-mul k k))
 823                    (setf (f2cl-lib:fref ispace-%data%
 824                                         (7)
 825                                         ((1 1))
 826                                         ispace-%offset%)
 827                            (f2cl-lib:int-sub
 828                             (f2cl-lib:int-add
 829                              (f2cl-lib:fref ispace-%data%
 830                                             (6)
 831                                             ((1 1))
 832                                             ispace-%offset%)
 833                              k2)
 834                             1))
 835                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 836                                  ((> i ncomp) nil)
 837                      (tagbody
 838                       label240
 839                        (setf (f2cl-lib:fref ispace-%data%
 840                                             ((f2cl-lib:int-add 7 i))
 841                                             ((1 1))
 842                                             ispace-%offset%)
 843                                (f2cl-lib:fref m-%data%
 844                                               (i)
 845                                               ((1 1))
 846                                               m-%offset%))))
 847                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 848                                  ((> i nz) nil)
 849                      (tagbody
 850                       label250
 851                        (setf (f2cl-lib:fref fspace-%data%
 852                                             ((f2cl-lib:int-add n 1 i))
 853                                             ((1 1))
 854                                             fspace-%offset%)
 855                                (f2cl-lib:fref fspace-%data%
 856                                               ((f2cl-lib:int-add
 857                                                 (f2cl-lib:int-sub lz 1)
 858                                                 i))
 859                                               ((1 1))
 860                                               fspace-%offset%))))
 861                    (setf idmz (f2cl-lib:int-add n 1 nz))
 862                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 863                                  ((> i ndmz) nil)
 864                      (tagbody
 865                       label255
 866                        (setf (f2cl-lib:fref fspace-%data%
 867                                             ((f2cl-lib:int-add idmz i))
 868                                             ((1 1))
 869                                             fspace-%offset%)
 870                                (f2cl-lib:fref fspace-%data%
 871                                               ((f2cl-lib:int-add
 872                                                 (f2cl-lib:int-sub ldmz 1)
 873                                                 i))
 874                                               ((1 1))
 875                                               fspace-%offset%))))
 876                    (setf ic (f2cl-lib:int-add idmz ndmz))
 877                    (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 878                                  ((> i k2) nil)
 879                      (tagbody
 880                       label258
 881                        (setf (f2cl-lib:fref fspace-%data%
 882                                             ((f2cl-lib:int-add ic i))
 883                                             ((1 1))
 884                                             fspace-%offset%)
 885                                (f2cl-lib:fref coef (i) ((1 49))))))
 886                    (go end_label)
 887                   end_label
 888                    (return
 889                     (values nil
 890                             nil
 891                             nil
 892                             nil
 893                             nil
 894                             nil
 895                             nil
 896                             nil
 897                             nil
 898                             nil
 899                             nil
 900                             iflag
 901                             nil
 902                             nil
 903                             nil
 904                             nil
 905                             nil))))))))
 906   (defun colnew
 907          (ncomp m aleft aright zeta ipar ltol tol fixpnt ispace fspace iflag
 908           fsub dfsub gsub dgsub guess)
 909     (multiple-value-bind
 910           (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16)
 911         (multi-entry-colnew 'colnew ncomp m aleft aright zeta ipar ltol tol
 912          fixpnt ispace fspace iflag fsub dfsub gsub dgsub guess)
 913       (values v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16)))
 914   (defun colsys
 915          (ncomp m aleft aright zeta ipar ltol tol fixpnt ispace fspace iflag
 916           fsub dfsub gsub dgsub guess)
 917     (multiple-value-bind
 918           (v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16)
 919         (multi-entry-colnew 'colsys ncomp m aleft aright zeta ipar ltol tol
 920          fixpnt ispace fspace iflag fsub dfsub gsub dgsub guess)
 921       (values v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16))))
 922
 923 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 924 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 925 (eval-when (:load-toplevel :compile-toplevel :execute)
 926   (setf (gethash 'fortran-to-lisp::colnew
 927                  fortran-to-lisp::*f2cl-function-info*)
 928           (fortran-to-lisp::make-f2cl-finfo
 929            :arg-types '((fortran-to-lisp::integer4)
 930                         (array fortran-to-lisp::integer4 (1)) double-float
 931                         double-float (array double-float (1))
 932                         (array fortran-to-lisp::integer4 (1))
 933                         (array fortran-to-lisp::integer4 (1))
 934                         (array double-float (1)) (array double-float (1))
 935                         (array fortran-to-lisp::integer4 (1))
 936                         (array double-float (1)) (fortran-to-lisp::integer4) t
 937                         t t t t)
 938            :return-values '(nil nil nil nil nil nil nil nil nil nil nil
 939                             fortran-to-lisp::iflag nil nil nil nil nil)
 940            :calls '(fortran-to-lisp::contrl fortran-to-lisp::newmsh
 941                     fortran-to-lisp::consts))))
 942