share/colnew/lisp/newmsh.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 newmsh (mode xi xiold z dmz valstr slope accum nfxpnt fixpnt)
  21   (declare (type (array double-float (*)) fixpnt accum slope valstr dmz z xiold
  22                                           xi)
  23            (type (f2cl-lib:integer4) nfxpnt mode))
  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         (colbas-asave
  30          (make-array 112
  31                      :element-type 'double-float
  32                      :displaced-to (colbas-part-0 *colbas-common-block*)
  33                      :displaced-index-offset 224))
  34         (colest-wgtmsh
  35          (make-array 40
  36                      :element-type 'double-float
  37                      :displaced-to (colest-part-0 *colest-common-block*)
  38                      :displaced-index-offset 40))
  39         (colest-root
  40          (make-array 40
  41                      :element-type 'double-float
  42                      :displaced-to (colest-part-0 *colest-common-block*)
  43                      :displaced-index-offset 160))
  44         (colest-jtol
  45          (make-array 40
  46                      :element-type 'f2cl-lib:integer4
  47                      :displaced-to (colest-part-1 *colest-common-block*)
  48                      :displaced-index-offset 0))
  49         (colest-ltol
  50          (make-array 40
  51                      :element-type 'f2cl-lib:integer4
  52                      :displaced-to (colest-part-1 *colest-common-block*)
  53                      :displaced-index-offset 40)))
  54     (symbol-macrolet ((precis (aref (colout-part-0 *colout-common-block*) 0))
  55                       (iout (aref (colout-part-1 *colout-common-block*) 0))
  56                       (iprint (aref (colout-part-1 *colout-common-block*) 1))
  57                       (k (aref (colord-part-0 *colord-common-block*) 0))
  58                       (ncomp (aref (colord-part-0 *colord-common-block*) 1))
  59                       (mstar (aref (colord-part-0 *colord-common-block*) 2))
  60                       (kd (aref (colord-part-0 *colord-common-block*) 3))
  61                       (mmax (aref (colord-part-0 *colord-common-block*) 4))
  62                       (m colord-m)
  63                       (n (aref (colapr-part-0 *colapr-common-block*) 0))
  64                       (nold (aref (colapr-part-0 *colapr-common-block*) 1))
  65                       (nmax (aref (colapr-part-0 *colapr-common-block*) 2))
  66                       (nz (aref (colapr-part-0 *colapr-common-block*) 3))
  67                       (ndmz (aref (colapr-part-0 *colapr-common-block*) 4))
  68                       (mshflg (aref (colmsh-part-0 *colmsh-common-block*) 0))
  69                       (mshnum (aref (colmsh-part-0 *colmsh-common-block*) 1))
  70                       (mshlmt (aref (colmsh-part-0 *colmsh-common-block*) 2))
  71                       (mshalt (aref (colmsh-part-0 *colmsh-common-block*) 3))
  72                       (iguess (aref (colnln-part-0 *colnln-common-block*) 4))
  73                       (aleft (aref (colsid-part-0 *colsid-common-block*) 40))
  74                       (aright (aref (colsid-part-0 *colsid-common-block*) 41))
  75                       (asave colbas-asave)
  76                       (wgtmsh colest-wgtmsh)
  77                       (root colest-root)
  78                       (jtol colest-jtol)
  79                       (ltol colest-ltol)
  80                       (ntol (aref (colest-part-1 *colest-common-block*) 80)))
  81       (f2cl-lib:with-multi-array-data
  82           ((xi double-float xi-%data% xi-%offset%)
  83            (xiold double-float xiold-%data% xiold-%offset%)
  84            (z double-float z-%data% z-%offset%)
  85            (dmz double-float dmz-%data% dmz-%offset%)
  86            (valstr double-float valstr-%data% valstr-%offset%)
  87            (slope double-float slope-%data% slope-%offset%)
  88            (accum double-float accum-%data% accum-%offset%)
  89            (fixpnt double-float fixpnt-%data% fixpnt-%offset%))
  90         (prog ((lcarry 0) (l 0) (tsum 0.0) (accr 0.0) (lnew 0) (lold 0)
  91                (accl 0.0) (in 0) (nmax2 0) (nmx 0) (naccum 0) (degequ 0.0)
  92                (avrg 0.0) (temp 0.0) (iflip 0) (slphmx 0.0) (jz 0) (jj 0)
  93                (oneovh 0.0) (hiold 0.0) (x 0.0) (hd6 0.0) (kstore 0) (n2 0)
  94                (dx 0.0) (nregn 0) (nmin 0) (iright 0) (xright 0.0) (xleft 0.0)
  95                (ileft 0) (np1 0) (j 0) (i 0) (noldp1 0) (nfxp1 0)
  96                (d2 (make-array 40 :element-type 'double-float))
  97                (d1 (make-array 40 :element-type 'double-float))
  98                (dummy (make-array 1 :element-type 'double-float)))
  99           (declare (type (array double-float (1)) dummy)
 100                    (type (array double-float (40)) d1 d2)
 101                    (type double-float xleft xright dx hd6 x hiold oneovh slphmx
 102                                       temp avrg degequ accl accr tsum)
 103                    (type (f2cl-lib:integer4) nfxp1 noldp1 i j np1 ileft iright
 104                                              nmin nregn n2 kstore jj jz iflip
 105                                              naccum nmx nmax2 in lold lnew l
 106                                              lcarry))
 107           (setf nfxp1 (f2cl-lib:int-add nfxpnt 1))
 108           (f2cl-lib:computed-goto (label180 label100 label50 label20 label10)
 109                                   mode)
 110          label10
 111           (setf mshlmt 1)
 112          label20
 113           (if (< iguess 2) (go label40))
 114           (setf noldp1 (f2cl-lib:int-add nold 1))
 115           (if (< iprint 1)
 116               (f2cl-lib:fformat iout
 117                                 ("~%" " THE FORMER MESH (OF" 1 (("~5D"))
 118                                  " SUBINTERVALS)," 100
 119                                  ("~%" 8 (("~12,6,0,'*,F"))) "~%")
 120                                 nold
 121                                 (do ((i 1 (f2cl-lib:int-add i 1))
 122                                      (%ret nil))
 123                                     ((> i noldp1) (nreverse %ret))
 124                                   (declare (type f2cl-lib:integer4 i))
 125                                   (push
 126                                    (f2cl-lib:fref xiold-%data%
 127                                                   (i)
 128                                                   ((1 1))
 129                                                   xiold-%offset%)
 130                                    %ret))))
 131           (if (/= iguess 3) (go label40))
 132           (setf n (the f2cl-lib:integer4 (truncate nold 2)))
 133           (setf i 0)
 134           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 2))
 135                         ((> j nold) nil)
 136             (tagbody
 137               (setf i (f2cl-lib:int-add i 1))
 138              label30
 139               (setf (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%)
 140                       (f2cl-lib:fref xiold-%data%
 141                                      (j)
 142                                      ((1 1))
 143                                      xiold-%offset%))))
 144          label40
 145           (setf np1 (f2cl-lib:int-add n 1))
 146           (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft)
 147           (setf (f2cl-lib:fref xi-%data% (np1) ((1 1)) xi-%offset%) aright)
 148           (go label320)
 149          label50
 150           (if (< n nfxp1) (setf n nfxp1))
 151           (setf np1 (f2cl-lib:int-add n 1))
 152           (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft)
 153           (setf ileft 1)
 154           (setf xleft aleft)
 155           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 156                         ((> j nfxp1) nil)
 157             (tagbody
 158               (setf xright aright)
 159               (setf iright np1)
 160               (if (= j nfxp1) (go label60))
 161               (setf xright
 162                       (f2cl-lib:fref fixpnt-%data%
 163                                      (j)
 164                                      ((1 1))
 165                                      fixpnt-%offset%))
 166               (setf nmin
 167                       (f2cl-lib:int
 168                        (+
 169                         (* (/ (- xright aleft) (- aright aleft))
 170                            (f2cl-lib:dfloat n))
 171                         1.5)))
 172               (if (> nmin (f2cl-lib:int-add (f2cl-lib:int-sub n nfxpnt) j))
 173                   (setf nmin (f2cl-lib:int-add (f2cl-lib:int-sub n nfxpnt) j)))
 174               (setf iright (f2cl-lib:max0 (f2cl-lib:int-add ileft 1) nmin))
 175              label60
 176               (setf (f2cl-lib:fref xi-%data% (iright) ((1 1)) xi-%offset%)
 177                       xright)
 178               (setf nregn (f2cl-lib:int-sub iright ileft 1))
 179               (if (= nregn 0) (go label80))
 180               (setf dx
 181                       (/ (- xright xleft)
 182                          (f2cl-lib:dfloat (f2cl-lib:int-add nregn 1))))
 183               (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 184                             ((> i nregn) nil)
 185                 (tagbody
 186                  label70
 187                   (setf (f2cl-lib:fref xi-%data%
 188                                        ((f2cl-lib:int-add ileft i))
 189                                        ((1 1))
 190                                        xi-%offset%)
 191                           (+ xleft (* (f2cl-lib:dfloat i) dx)))))
 192              label80
 193               (setf ileft iright)
 194               (setf xleft xright)
 195              label90))
 196           (go label320)
 197          label100
 198           (setf n2 (f2cl-lib:int-mul 2 n))
 199           (if (<= n2 nmax) (go label120))
 200           (if (= mode 2) (go label110))
 201           (setf n (the f2cl-lib:integer4 (truncate nmax 2)))
 202           (go label220)
 203          label110
 204           (if (< iprint 1)
 205               (f2cl-lib:fformat iout ("~%" "  EXPECTED N TOO LARGE " "~%")))
 206           (setf n n2)
 207           (go end_label)
 208          label120
 209           (if (= mshflg 0) (go label140))
 210           (setf kstore 1)
 211           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 212                         ((> i nold) nil)
 213             (tagbody
 214               (setf hd6
 215                       (/
 216                        (-
 217                         (f2cl-lib:fref xiold-%data%
 218                                        ((f2cl-lib:int-add i 1))
 219                                        ((1 1))
 220                                        xiold-%offset%)
 221                         (f2cl-lib:fref xiold-%data%
 222                                        (i)
 223                                        ((1 1))
 224                                        xiold-%offset%))
 225                        6.0))
 226               (setf x
 227                       (+
 228                        (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%)
 229                        hd6))
 230               (multiple-value-bind
 231                     (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 232                      var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 233                   (approx i x
 234                    (f2cl-lib:array-slice valstr double-float (kstore) ((1 1)))
 235                    (f2cl-lib:array-slice asave
 236                                          double-float
 237                                          (1 1)
 238                                          ((1 28) (1 4)))
 239                    dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0)
 240                 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8
 241                                  var-9 var-10 var-11 var-12 var-13 var-14
 242                                  var-15 var-16))
 243                 (setf i var-0)
 244                 (setf x var-1))
 245               (setf x (+ x (* 4.0 hd6)))
 246               (setf kstore
 247                       (f2cl-lib:int-add kstore (f2cl-lib:int-mul 3 mstar)))
 248               (multiple-value-bind
 249                     (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 250                      var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 251                   (approx i x
 252                    (f2cl-lib:array-slice valstr double-float (kstore) ((1 1)))
 253                    (f2cl-lib:array-slice asave
 254                                          double-float
 255                                          (1 4)
 256                                          ((1 28) (1 4)))
 257                    dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0)
 258                 (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8
 259                                  var-9 var-10 var-11 var-12 var-13 var-14
 260                                  var-15 var-16))
 261                 (setf i var-0)
 262                 (setf x var-1))
 263               (setf kstore (f2cl-lib:int-add kstore mstar))
 264              label130))
 265           (go label160)
 266          label140
 267           (setf kstore 1)
 268           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 269                         ((> i n) nil)
 270             (tagbody
 271               (setf x (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))
 272               (setf hd6
 273                       (/
 274                        (-
 275                         (f2cl-lib:fref xi-%data%
 276                                        ((f2cl-lib:int-add i 1))
 277                                        ((1 1))
 278                                        xi-%offset%)
 279                         (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))
 280                        6.0))
 281               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 282                             ((> j 4) nil)
 283                 (tagbody
 284                   (setf x (+ x hd6))
 285                   (if (= j 3) (setf x (+ x hd6)))
 286                   (multiple-value-bind
 287                         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 288                          var-9 var-10 var-11 var-12 var-13 var-14 var-15
 289                          var-16)
 290                       (approx i x
 291                        (f2cl-lib:array-slice valstr
 292                                              double-float
 293                                              (kstore)
 294                                              ((1 1)))
 295                        (f2cl-lib:array-slice asave
 296                                              double-float
 297                                              (1 j)
 298                                              ((1 28) (1 4)))
 299                        dummy xiold nold z dmz k ncomp mmax m mstar 4 dummy 0)
 300                     (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8
 301                                      var-9 var-10 var-11 var-12 var-13 var-14
 302                                      var-15 var-16))
 303                     (setf i var-0)
 304                     (setf x var-1))
 305                   (setf kstore (f2cl-lib:int-add kstore mstar))
 306                  label150))))
 307          label150
 308          label160
 309           (setf mshflg 0)
 310           (setf mshnum 1)
 311           (setf mode 2)
 312           (setf j 2)
 313           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 314                         ((> i n) nil)
 315             (tagbody
 316               (setf (f2cl-lib:fref xi-%data% (j) ((1 1)) xi-%offset%)
 317                       (/
 318                        (+
 319                         (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%)
 320                         (f2cl-lib:fref xiold-%data%
 321                                        ((f2cl-lib:int-add i 1))
 322                                        ((1 1))
 323                                        xiold-%offset%))
 324                        2.0))
 325               (setf (f2cl-lib:fref xi-%data%
 326                                    ((f2cl-lib:int-add j 1))
 327                                    ((1 1))
 328                                    xi-%offset%)
 329                       (f2cl-lib:fref xiold-%data%
 330                                      ((f2cl-lib:int-add i 1))
 331                                      ((1 1))
 332                                      xiold-%offset%))
 333              label170
 334               (setf j (f2cl-lib:int-add j 2))))
 335           (setf n n2)
 336           (go label320)
 337          label180
 338           (if (= nold 1) (go label100))
 339           (if (<= nold (f2cl-lib:int-mul 2 nfxpnt)) (go label100))
 340           (setf i 1)
 341           (setf hiold
 342                   (- (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%)
 343                      (f2cl-lib:fref xiold-%data% (1) ((1 1)) xiold-%offset%)))
 344           (horder 1 d1 hiold dmz ncomp k)
 345           (setf hiold
 346                   (- (f2cl-lib:fref xiold-%data% (3) ((1 1)) xiold-%offset%)
 347                      (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%)))
 348           (horder 2 d2 hiold dmz ncomp k)
 349           (setf (f2cl-lib:fref accum-%data% (1) ((1 1)) accum-%offset%) 0.0)
 350           (setf (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%) 0.0)
 351           (setf oneovh
 352                   (/ 2.0
 353                      (- (f2cl-lib:fref xiold-%data% (3) ((1 1)) xiold-%offset%)
 354                         (f2cl-lib:fref xiold-%data%
 355                                        (1)
 356                                        ((1 1))
 357                                        xiold-%offset%))))
 358           (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 359                         ((> j ntol) nil)
 360             (tagbody
 361               (setf jj (f2cl-lib:fref jtol (j) ((1 40))))
 362               (setf jz (f2cl-lib:fref ltol (j) ((1 40))))
 363              label190
 364               (setf (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%)
 365                       (f2cl-lib:dmax1
 366                        (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%)
 367                        (expt
 368                         (/
 369                          (*
 370                           (f2cl-lib:dabs
 371                            (- (f2cl-lib:fref d2 (jj) ((1 40)))
 372                               (f2cl-lib:fref d1 (jj) ((1 40)))))
 373                           (f2cl-lib:fref wgtmsh (j) ((1 40)))
 374                           oneovh)
 375                          (+ 1.0
 376                             (f2cl-lib:dabs
 377                              (f2cl-lib:fref z-%data%
 378                                             (jz)
 379                                             ((1 1))
 380                                             z-%offset%))))
 381                         (f2cl-lib:fref root (j) ((1 40))))))))
 382           (setf slphmx
 383                   (* (f2cl-lib:fref slope-%data% (1) ((1 1)) slope-%offset%)
 384                      (- (f2cl-lib:fref xiold-%data% (2) ((1 1)) xiold-%offset%)
 385                         (f2cl-lib:fref xiold-%data%
 386                                        (1)
 387                                        ((1 1))
 388                                        xiold-%offset%))))
 389           (setf (f2cl-lib:fref accum-%data% (2) ((1 1)) accum-%offset%) slphmx)
 390           (setf iflip 1)
 391           (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
 392                         ((> i nold) nil)
 393             (tagbody
 394               (setf hiold
 395                       (-
 396                        (f2cl-lib:fref xiold-%data%
 397                                       ((f2cl-lib:int-add i 1))
 398                                       ((1 1))
 399                                       xiold-%offset%)
 400                        (f2cl-lib:fref xiold-%data%
 401                                       (i)
 402                                       ((1 1))
 403                                       xiold-%offset%)))
 404               (if (= iflip -1) (horder i d1 hiold dmz ncomp k))
 405               (if (= iflip 1) (horder i d2 hiold dmz ncomp k))
 406               (setf oneovh
 407                       (/ 2.0
 408                          (-
 409                           (f2cl-lib:fref xiold-%data%
 410                                          ((f2cl-lib:int-add i 1))
 411                                          ((1 1))
 412                                          xiold-%offset%)
 413                           (f2cl-lib:fref xiold-%data%
 414                                          ((f2cl-lib:int-sub i 1))
 415                                          ((1 1))
 416                                          xiold-%offset%))))
 417               (setf (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%)
 418                       0.0)
 419               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 420                             ((> j ntol) nil)
 421                 (tagbody
 422                   (setf jj (f2cl-lib:fref jtol (j) ((1 40))))
 423                   (setf jz
 424                           (f2cl-lib:int-add (f2cl-lib:fref ltol (j) ((1 40)))
 425                                             (f2cl-lib:int-mul
 426                                              (f2cl-lib:int-sub i 1)
 427                                              mstar)))
 428                  label200
 429                   (setf (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%)
 430                           (f2cl-lib:dmax1
 431                            (f2cl-lib:fref slope-%data%
 432                                           (i)
 433                                           ((1 1))
 434                                           slope-%offset%)
 435                            (expt
 436                             (/
 437                              (*
 438                               (f2cl-lib:dabs
 439                                (- (f2cl-lib:fref d2 (jj) ((1 40)))
 440                                   (f2cl-lib:fref d1 (jj) ((1 40)))))
 441                               (f2cl-lib:fref wgtmsh (j) ((1 40)))
 442                               oneovh)
 443                              (+ 1.0
 444                                 (f2cl-lib:dabs
 445                                  (f2cl-lib:fref z-%data%
 446                                                 (jz)
 447                                                 ((1 1))
 448                                                 z-%offset%))))
 449                             (f2cl-lib:fref root (j) ((1 40))))))))
 450               (setf temp
 451                       (*
 452                        (f2cl-lib:fref slope-%data% (i) ((1 1)) slope-%offset%)
 453                        (-
 454                         (f2cl-lib:fref xiold-%data%
 455                                        ((f2cl-lib:int-add i 1))
 456                                        ((1 1))
 457                                        xiold-%offset%)
 458                         (f2cl-lib:fref xiold-%data%
 459                                        (i)
 460                                        ((1 1))
 461                                        xiold-%offset%))))
 462               (setf slphmx (f2cl-lib:dmax1 slphmx temp))
 463               (setf (f2cl-lib:fref accum-%data%
 464                                    ((f2cl-lib:int-add i 1))
 465                                    ((1 1))
 466                                    accum-%offset%)
 467                       (+
 468                        (f2cl-lib:fref accum-%data% (i) ((1 1)) accum-%offset%)
 469                        temp))
 470              label210
 471               (setf iflip (f2cl-lib:int-sub iflip))))
 472           (setf avrg
 473                   (/
 474                    (f2cl-lib:fref accum-%data%
 475                                   ((f2cl-lib:int-add nold 1))
 476                                   ((1 1))
 477                                   accum-%offset%)
 478                    (f2cl-lib:dfloat nold)))
 479           (setf degequ (/ avrg (f2cl-lib:dmax1 slphmx precis)))
 480           (setf naccum
 481                   (f2cl-lib:int
 482                    (+
 483                     (f2cl-lib:fref accum-%data%
 484                                    ((f2cl-lib:int-add nold 1))
 485                                    ((1 1))
 486                                    accum-%offset%)
 487                     1.0)))
 488           (if (< iprint 0)
 489               (f2cl-lib:fformat iout
 490                                 ("~%" " MESH SELECTION INFO," "~%"
 491                                  " DEGREE OF EQUIDISTRIBUTION = " 1
 492                                  (("~8,5,0,'*,F"))
 493                                  " PREDICTION FOR REQUIRED N =" 1 (("~8D"))
 494                                  "~%")
 495                                 degequ
 496                                 naccum))
 497           (if (< avrg precis) (go label100))
 498           (if (>= degequ 0.5) (go label100))
 499           (setf nmx
 500                   (the f2cl-lib:integer4
 501                        (truncate (f2cl-lib:max0 (+ nold 1) naccum) 2)))
 502           (setf nmax2 (the f2cl-lib:integer4 (truncate nmax 2)))
 503           (setf n (f2cl-lib:min0 nmax2 nold nmx))
 504          label220
 505           (setf noldp1 (f2cl-lib:int-add nold 1))
 506           (if (< n nfxp1) (setf n nfxp1))
 507           (setf mshnum (f2cl-lib:int-add mshnum 1))
 508           (if (< n nold) (setf mshnum mshlmt))
 509           (if (> n (the f2cl-lib:integer4 (truncate nold 2))) (setf mshalt 1))
 510           (if (= n (the f2cl-lib:integer4 (truncate nold 2)))
 511               (setf mshalt (f2cl-lib:int-add mshalt 1)))
 512           (setf mshflg 0)
 513           (setf in 1)
 514           (setf accl 0.0)
 515           (setf lold 2)
 516           (setf (f2cl-lib:fref xi-%data% (1) ((1 1)) xi-%offset%) aleft)
 517           (setf (f2cl-lib:fref xi-%data%
 518                                ((f2cl-lib:int-add n 1))
 519                                ((1 1))
 520                                xi-%offset%)
 521                   aright)
 522           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 523                         ((> i nfxp1) nil)
 524             (tagbody
 525               (if (= i nfxp1) (go label250))
 526               (f2cl-lib:fdo (j lold (f2cl-lib:int-add j 1))
 527                             ((> j noldp1) nil)
 528                 (tagbody
 529                   (setf lnew j)
 530                   (if
 531                    (<=
 532                     (f2cl-lib:fref fixpnt-%data% (i) ((1 1)) fixpnt-%offset%)
 533                     (f2cl-lib:fref xiold-%data% (j) ((1 1)) xiold-%offset%))
 534                    (go label240))
 535                  label230))
 536              label240
 537               (setf accr
 538                       (+
 539                        (f2cl-lib:fref accum-%data%
 540                                       (lnew)
 541                                       ((1 1))
 542                                       accum-%offset%)
 543                        (*
 544                         (-
 545                          (f2cl-lib:fref fixpnt-%data%
 546                                         (i)
 547                                         ((1 1))
 548                                         fixpnt-%offset%)
 549                          (f2cl-lib:fref xiold-%data%
 550                                         (lnew)
 551                                         ((1 1))
 552                                         xiold-%offset%))
 553                         (f2cl-lib:fref slope-%data%
 554                                        ((f2cl-lib:int-sub lnew 1))
 555                                        ((1 1))
 556                                        slope-%offset%))))
 557               (setf nregn
 558                       (f2cl-lib:int
 559                        (-
 560                         (*
 561                          (/ (- accr accl)
 562                             (f2cl-lib:fref accum-%data%
 563                                            (noldp1)
 564                                            ((1 1))
 565                                            accum-%offset%))
 566                          (f2cl-lib:dfloat n))
 567                         0.5)))
 568               (setf nregn
 569                       (f2cl-lib:min0 nregn
 570                                      (f2cl-lib:int-add
 571                                       (f2cl-lib:int-sub n in nfxp1)
 572                                       i)))
 573               (setf (f2cl-lib:fref xi-%data%
 574                                    ((f2cl-lib:int-add in nregn 1))
 575                                    ((1 1))
 576                                    xi-%offset%)
 577                       (f2cl-lib:fref fixpnt-%data%
 578                                      (i)
 579                                      ((1 1))
 580                                      fixpnt-%offset%))
 581               (go label260)
 582              label250
 583               (setf accr
 584                       (f2cl-lib:fref accum-%data%
 585                                      (noldp1)
 586                                      ((1 1))
 587                                      accum-%offset%))
 588               (setf lnew noldp1)
 589               (setf nregn (f2cl-lib:int-sub n in))
 590              label260
 591               (if (= nregn 0) (go label300))
 592               (setf temp accl)
 593               (setf tsum
 594                       (/ (- accr accl)
 595                          (f2cl-lib:dfloat (f2cl-lib:int-add nregn 1))))
 596               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 597                             ((> j nregn) nil)
 598                 (tagbody
 599                   (setf in (f2cl-lib:int-add in 1))
 600                   (setf temp (+ temp tsum))
 601                   (f2cl-lib:fdo (l lold (f2cl-lib:int-add l 1))
 602                                 ((> l lnew) nil)
 603                     (tagbody
 604                       (setf lcarry l)
 605                       (if
 606                        (<= temp
 607                            (f2cl-lib:fref accum-%data%
 608                                           (l)
 609                                           ((1 1))
 610                                           accum-%offset%))
 611                        (go label280))
 612                      label270))
 613                  label280
 614                   (setf lold lcarry)
 615                  label290
 616                   (setf (f2cl-lib:fref xi-%data% (in) ((1 1)) xi-%offset%)
 617                           (+
 618                            (f2cl-lib:fref xiold-%data%
 619                                           ((f2cl-lib:int-sub lold 1))
 620                                           ((1 1))
 621                                           xiold-%offset%)
 622                            (/
 623                             (- temp
 624                                (f2cl-lib:fref accum-%data%
 625                                               ((f2cl-lib:int-sub lold 1))
 626                                               ((1 1))
 627                                               accum-%offset%))
 628                             (f2cl-lib:fref slope-%data%
 629                                            ((f2cl-lib:int-sub lold 1))
 630                                            ((1 1))
 631                                            slope-%offset%))))))
 632              label300
 633               (setf in (f2cl-lib:int-add in 1))
 634               (setf accl accr)
 635               (setf lold lnew)
 636              label310))
 637           (setf mode 1)
 638          label320
 639           (setf np1 (f2cl-lib:int-add n 1))
 640           (if (< iprint 1)
 641               (f2cl-lib:fformat iout
 642                                 ("~%" " THE NEW MESH (OF" 1 (("~5D"))
 643                                  " SUBINTERVALS), " 100
 644                                  ("~%" 8 (("~12,6,0,'*,F"))) "~%")
 645                                 n
 646                                 (do ((i 1 (f2cl-lib:int-add i 1))
 647                                      (%ret nil))
 648                                     ((> i np1) (nreverse %ret))
 649                                   (declare (type f2cl-lib:integer4 i))
 650                                   (push
 651                                    (f2cl-lib:fref xi-%data%
 652                                                   (i)
 653                                                   ((1 1))
 654                                                   xi-%offset%)
 655                                    %ret))))
 656           (setf nz (f2cl-lib:int-mul mstar (f2cl-lib:int-add n 1)))
 657           (setf ndmz (f2cl-lib:int-mul kd n))
 658           (go end_label)
 659          end_label
 660           (return (values mode nil nil nil nil nil nil nil nil nil)))))))
 661
 662 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 663 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 664 (eval-when (:load-toplevel :compile-toplevel :execute)
 665   (setf (gethash 'fortran-to-lisp::newmsh
 666                  fortran-to-lisp::*f2cl-function-info*)
 667           (fortran-to-lisp::make-f2cl-finfo
 668            :arg-types '((fortran-to-lisp::integer4) (array double-float (1))
 669                         (array double-float (1)) (array double-float (1))
 670                         (array double-float (1)) (array double-float (1))
 671                         (array double-float (1)) (array double-float (1))
 672                         (fortran-to-lisp::integer4) (array double-float (1)))
 673            :return-values '(fortran-to-lisp::mode nil nil nil nil nil nil nil
 674                             nil nil)
 675            :calls '(fortran-to-lisp::horder fortran-to-lisp::approx))))
 676