share/colnew/ex3/prob3.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 t)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :colnew)
  18
  19
  20 (defstruct (%blank%
  21              (:predicate is-%blank%-p))
  22   (en 0.0 :type double-float)
  23   (s 0.0 :type double-float)
  24   (el 0.0 :type double-float)
  25   (cons$ 0.0 :type double-float))
  26
  27
  28 (defparameter *%blank%-common-block*
  29   (let* ()
  30     (declare (ignorable))
  31     (make-%blank%)))
  32
  33
  34 (let ((sval
  35        (make-array 3
  36                    :element-type 'double-float
  37                    :initial-contents '(0.2 0.1 0.05)))
  38       (elval
  39        (make-array 3
  40                    :element-type 'double-float
  41                    :initial-contents '(60.0 120.0 200.0))))
  42   (declare (type (array double-float (3)) sval elval))
  43   (defun *main* ()
  44     (let ()
  45       (symbol-macrolet ((cons$ (%blank%-cons$ *%blank%-common-block*))
  46                         (el (%blank%-el *%blank%-common-block*))
  47                         (s (%blank%-s *%blank%-common-block*))
  48                         (en (%blank%-en *%blank%-common-block*)))
  49         (prog ((xl 0.0) (dm 0.0) (iii 0) (np1 0) (x 0.0) (is4 0) (is5 0)
  50                (is6 0) (iflag 0) (fixpnt 0.0) (ijk 0) (aright 0.0) (aleft 0.0)
  51                (ncomp 0) (tol (make-array 2 :element-type 'double-float))
  52                (fspace (make-array 40000 :element-type 'double-float))
  53                (zeta (make-array 5 :element-type 'double-float))
  54                (ipar (make-array 11 :element-type 'f2cl-lib:integer4))
  55                (ltol (make-array 2 :element-type 'f2cl-lib:integer4))
  56                (ispace (make-array 2500 :element-type 'f2cl-lib:integer4))
  57                (m (make-array 2 :element-type 'f2cl-lib:integer4))
  58                (z (make-array 5 :element-type 'double-float))
  59                (a (make-array 28 :element-type 'double-float)))
  60           (declare (type (array double-float (28)) a)
  61                    (type (array f2cl-lib:integer4 (2500)) ispace)
  62                    (type (array f2cl-lib:integer4 (2)) m ltol)
  63                    (type (array f2cl-lib:integer4 (11)) ipar)
  64                    (type (array double-float (5)) z zeta)
  65                    (type (array double-float (40000)) fspace)
  66                    (type (array double-float (2)) tol)
  67                    (type (f2cl-lib:integer4) ncomp ijk iflag is6 is5 is4 np1
  68                                              iii)
  69                    (type double-float aleft aright fixpnt x dm xl))
  70           (setf en (coerce 0.2f0 'double-float))
  71           (setf cons$ (* 0.5f0 (- 3.0f0 en)))
  72           (setf ncomp 2)
  73           (setf (f2cl-lib:fref m (1) ((1 2))) 2)
  74           (setf (f2cl-lib:fref m (2) ((1 2))) 3)
  75           (setf aleft (coerce 0.0f0 'double-float))
  76           (setf aright (coerce 1.0f0 'double-float))
  77           (setf (f2cl-lib:fref zeta (1) ((1 5))) (coerce 0.0f0 'double-float))
  78           (setf (f2cl-lib:fref zeta (2) ((1 5))) (coerce 0.0f0 'double-float))
  79           (setf (f2cl-lib:fref zeta (3) ((1 5))) (coerce 0.0f0 'double-float))
  80           (setf (f2cl-lib:fref zeta (4) ((1 5))) (coerce 1.0f0 'double-float))
  81           (setf (f2cl-lib:fref zeta (5) ((1 5))) (coerce 1.0f0 'double-float))
  82           (setf (f2cl-lib:fref ipar (1) ((1 11))) 1)
  83           (setf (f2cl-lib:fref ipar (2) ((1 11))) 4)
  84           (setf (f2cl-lib:fref ipar (3) ((1 11))) 10)
  85           (setf (f2cl-lib:fref ipar (4) ((1 11))) 2)
  86           (setf (f2cl-lib:fref ipar (5) ((1 11))) 40000)
  87           (setf (f2cl-lib:fref ipar (6) ((1 11))) 2500)
  88           (setf (f2cl-lib:fref ipar (7) ((1 11))) 0)
  89           (setf (f2cl-lib:fref ipar (8) ((1 11))) 0)
  90           (setf (f2cl-lib:fref ipar (9) ((1 11))) 1)
  91           (setf (f2cl-lib:fref ipar (10) ((1 11))) 0)
  92           (setf (f2cl-lib:fref ipar (11) ((1 11))) 0)
  93           (setf (f2cl-lib:fref ltol (1) ((1 2))) 1)
  94           (setf (f2cl-lib:fref ltol (2) ((1 2))) 3)
  95           (setf (f2cl-lib:fref tol (1) ((1 2))) (coerce 1.0f-5 'double-float))
  96           (setf (f2cl-lib:fref tol (2) ((1 2))) (coerce 1.0f-5 'double-float))
  97           (f2cl-lib:fdo (ijk 1 (f2cl-lib:int-add ijk 1))
  98                         ((> ijk 3) nil)
  99             (tagbody
 100               (setf s (f2cl-lib:fref sval (ijk) ((1 3))))
 101               (setf el (f2cl-lib:fref elval (ijk) ((1 3))))
 102               (if (= ijk 1) (go label10))
 103               (setf (f2cl-lib:fref ipar (9) ((1 11))) 3)
 104               (setf (f2cl-lib:fref ipar (3) ((1 11)))
 105                       (f2cl-lib:fref ispace (1) ((1 2500))))
 106              label10
 107               (f2cl-lib:fformat 6
 108                                 ("1" " ROTATING FLOW OVER A STATIONARY DISK."
 109                                  "~%" "  PARAME" "TERS -  N =" 1
 110                                  (("~5,2,0,'*,F")) "   S =" 1 (("~5,2,0,'*,F"))
 111                                  "   L =" 1 (("~6,1,0,'*,F")) "~%" "~%")
 112                                 en
 113                                 s
 114                                 el)
 115               (multiple-value-bind
 116                     (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 117                      var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16)
 118                   (colsys ncomp m aleft aright zeta ipar ltol tol
 119                    (make-array 1
 120                                :element-type (type-of fixpnt)
 121                                :initial-element fixpnt)
 122                    ispace fspace iflag #'fsub #'dfsub #'gsub #'dgsub #'solutn)
 123                 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6
 124                                  var-7 var-8 var-9 var-10 var-12 var-13 var-14
 125                                  var-15 var-16))
 126                 (setf iflag var-11))
 127               (if (/= iflag 1) (f2cl-lib::stop))
 128               (setf is6 (f2cl-lib:fref ispace (6) ((1 2500))))
 129               (setf is5
 130                       (f2cl-lib:int-add (f2cl-lib:fref ispace (1) ((1 2500)))
 131                                         2))
 132               (setf is4
 133                       (f2cl-lib:int-add is5
 134                                         (f2cl-lib:int-mul
 135                                          (f2cl-lib:fref ispace (4) ((1 2500)))
 136                                          (f2cl-lib:int-add
 137                                           (f2cl-lib:fref ispace (1) ((1 2500)))
 138                                           1))))
 139               (setf x (coerce 0.0f0 'double-float))
 140               (f2cl-lib:fformat 6
 141                                 ("1"
 142                                  "       X              G              DG     "
 143                                  "       H             DH            D2H" "~%"
 144                                  "~%"))
 145               (setf np1 (f2cl-lib:int (+ el 1.5f0)))
 146               (f2cl-lib:fdo (iii 1 (f2cl-lib:int-add iii 1))
 147                             ((> iii np1) nil)
 148                 (tagbody
 149                   (multiple-value-bind
 150                         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
 151                          var-9 var-10 var-11 var-12 var-13 var-14 var-15
 152                          var-16)
 153                       (approx iii x z a
 154                        (f2cl-lib:array-slice fspace
 155                                              double-float
 156                                              (is6)
 157                                              ((1 40000)))
 158                        (f2cl-lib:array-slice fspace
 159                                              double-float
 160                                              (1)
 161                                              ((1 40000)))
 162                        (f2cl-lib:fref ispace (1) ((1 2500)))
 163                        (f2cl-lib:array-slice fspace
 164                                              double-float
 165                                              (is5)
 166                                              ((1 40000)))
 167                        (f2cl-lib:array-slice fspace
 168                                              double-float
 169                                              (is4)
 170                                              ((1 40000)))
 171                        (f2cl-lib:fref ispace (2) ((1 2500)))
 172                        (f2cl-lib:fref ispace (3) ((1 2500)))
 173                        (f2cl-lib:fref ispace (5) ((1 2500)))
 174                        (f2cl-lib:array-slice ispace
 175                                              f2cl-lib:integer4
 176                                              (8)
 177                                              ((1 2500)))
 178                        (f2cl-lib:fref ispace (4) ((1 2500))) 1
 179                        (make-array 1
 180                                    :element-type (type-of dm)
 181                                    :initial-element dm)
 182                        0)
 183                     (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8
 184                                      var-9 var-10 var-11 var-12 var-13 var-14
 185                                      var-15 var-16))
 186                     (setf iii var-0)
 187                     (setf x var-1))
 188                   (setf xl (* x el))
 189                   (setf (f2cl-lib:fref z (2) ((1 5)))
 190                           (/ (f2cl-lib:fref z (2) ((1 5))) el))
 191                   (setf (f2cl-lib:fref z (4) ((1 5)))
 192                           (/ (f2cl-lib:fref z (4) ((1 5))) el))
 193                   (setf (f2cl-lib:fref z (5) ((1 5)))
 194                           (/ (/ (f2cl-lib:fref z (5) ((1 5))) el) el))
 195                   (f2cl-lib:fformat 6 (6 (("~15,5,2,0,'*,,'EE")) "~%") xl z)
 196                   (setf x (+ x (/ 1.0f0 el)))
 197                  label20))
 198              label30))
 199           (f2cl-lib::stop)
 200          end_label
 201           (return nil))))))
 202
 203 (in-package #:cl-user)
 204 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 205 (eval-when (:load-toplevel :compile-toplevel :execute)
 206   (setf (gethash 'fortran-to-lisp::*main*
 207                  fortran-to-lisp::*f2cl-function-info*)
 208           (fortran-to-lisp::make-f2cl-finfo :arg-types 'nil
 209                                             :return-values 'nil
 210                                             :calls 'nil)))
 211