share/hompack/lisp/fode.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   3 ;;;  "f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   4 ;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   5 ;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   6 ;;;  "f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v 1409c1352feb 2013/03/24 20:44:50 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2020-04 (21D Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "HOMPACK")
  18
  19
  20 (defun fode (s y yp ypold a qr alpha tz pivot nfe n iflag par ipar)
  21   (declare (type (array f2cl-lib:integer4 (*)) ipar)
  22            (type (array double-float (*)) par)
  23            (type (f2cl-lib:integer4) iflag n nfe)
  24            (type (array f2cl-lib:integer4 (*)) pivot)
  25            (type (array double-float (*)) tz alpha qr a ypold yp y)
  26            (type (double-float) s))
  27   (f2cl-lib:with-multi-array-data
  28       ((y double-float y-%data% y-%offset%)
  29        (yp double-float yp-%data% yp-%offset%)
  30        (ypold double-float ypold-%data% ypold-%offset%)
  31        (a double-float a-%data% a-%offset%)
  32        (qr double-float qr-%data% qr-%offset%)
  33        (alpha double-float alpha-%data% alpha-%offset%)
  34        (tz double-float tz-%data% tz-%offset%)
  35        (pivot f2cl-lib:integer4 pivot-%data% pivot-%offset%)
  36        (par double-float par-%data% par-%offset%)
  37        (ipar f2cl-lib:integer4 ipar-%data% ipar-%offset%))
  38     (prog ((i 0) (ierr 0) (ik 0) (j 0) (k 0) (kp1 0) (kpiv 0) (lw 0) (np1 0)
  39            (sum 0.0) (ypnorm 0.0))
  40       (declare (type (double-float) ypnorm sum)
  41                (type (f2cl-lib:integer4) np1 lw kpiv kp1 k j ik ierr i))
  42       (setf np1 (f2cl-lib:int-add n 1))
  43       (setf nfe (f2cl-lib:int-add nfe 1))
  44       (cond
  45         ((= iflag (f2cl-lib:int-sub 2))
  46          (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  47                        ((> k np1) nil)
  48            (tagbody
  49              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
  50                  (rhojac a
  51                   (f2cl-lib:fref y-%data%
  52                                  (1)
  53                                  ((1 (f2cl-lib:int-add n 1)))
  54                                  y-%offset%)
  55                   (f2cl-lib:array-slice y-%data%
  56                                         double-float
  57                                         (2)
  58                                         ((1 (f2cl-lib:int-add n 1)))
  59                                         y-%offset%)
  60                   (f2cl-lib:array-slice qr-%data%
  61                                         double-float
  62                                         (1 k)
  63                                         ((1 n) (1 (f2cl-lib:int-add n 1)))
  64                                         qr-%offset%)
  65                   k par ipar)
  66                (declare (ignore var-0 var-2 var-3 var-4 var-5 var-6))
  67                (setf (f2cl-lib:fref y-%data%
  68                                     (1)
  69                                     ((1 (f2cl-lib:int-add n 1)))
  70                                     y-%offset%)
  71                        var-1))
  72             label30)))
  73         (t
  74          (f
  75           (f2cl-lib:array-slice y-%data%
  76                                 double-float
  77                                 (2)
  78                                 ((1 (f2cl-lib:int-add n 1)))
  79                                 y-%offset%)
  80           tz)
  81          (cond
  82            ((= iflag 0)
  83             (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  84                           ((> j n) nil)
  85               (tagbody
  86                label100
  87                 (setf (f2cl-lib:fref qr-%data%
  88                                      (j 1)
  89                                      ((1 n) (1 (f2cl-lib:int-add n 1)))
  90                                      qr-%offset%)
  91                         (- (f2cl-lib:fref a-%data% (j) ((1 n)) a-%offset%)
  92                            (f2cl-lib:fref tz-%data%
  93                                           (j)
  94                                           ((1 (f2cl-lib:int-add n 1)))
  95                                           tz-%offset%)))))
  96             (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  97                           ((> k n) nil)
  98               (tagbody
  99                 (fjac
 100                  (f2cl-lib:array-slice y-%data%
 101                                        double-float
 102                                        (2)
 103                                        ((1 (f2cl-lib:int-add n 1)))
 104                                        y-%offset%)
 105                  tz k)
 106                 (setf kp1 (f2cl-lib:int-add k 1))
 107                 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 108                               ((> j n) nil)
 109                   (tagbody
 110                    label110
 111                     (setf (f2cl-lib:fref qr-%data%
 112                                          (j kp1)
 113                                          ((1 n) (1 (f2cl-lib:int-add n 1)))
 114                                          qr-%offset%)
 115                             (*
 116                              (-
 117                               (f2cl-lib:fref y-%data%
 118                                              (1)
 119                                              ((1 (f2cl-lib:int-add n 1)))
 120                                              y-%offset%))
 121                              (f2cl-lib:fref tz-%data%
 122                                             (j)
 123                                             ((1 (f2cl-lib:int-add n 1)))
 124                                             tz-%offset%)))))
 125                label120
 126                 (setf (f2cl-lib:fref qr-%data%
 127                                      (k kp1)
 128                                      ((1 n) (1 (f2cl-lib:int-add n 1)))
 129                                      qr-%offset%)
 130                         (+ 1.0f0
 131                            (f2cl-lib:fref qr-%data%
 132                                           (k kp1)
 133                                           ((1 n) (1 (f2cl-lib:int-add n 1)))
 134                                           qr-%offset%))))))
 135            (t
 136             (tagbody
 137              label140
 138               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 139                             ((> j n) nil)
 140                 (tagbody
 141                  label150
 142                   (setf (f2cl-lib:fref qr-%data%
 143                                        (j 1)
 144                                        ((1 n) (1 (f2cl-lib:int-add n 1)))
 145                                        qr-%offset%)
 146                           (+
 147                            (-
 148                             (f2cl-lib:fref tz-%data%
 149                                            (j)
 150                                            ((1 (f2cl-lib:int-add n 1)))
 151                                            tz-%offset%)
 152                             (f2cl-lib:fref y-%data%
 153                                            ((f2cl-lib:int-add j 1))
 154                                            ((1 (f2cl-lib:int-add n 1)))
 155                                            y-%offset%))
 156                            (f2cl-lib:fref a-%data% (j) ((1 n)) a-%offset%)))))
 157               (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 158                             ((> k n) nil)
 159                 (tagbody
 160                   (fjac
 161                    (f2cl-lib:array-slice y-%data%
 162                                          double-float
 163                                          (2)
 164                                          ((1 (f2cl-lib:int-add n 1)))
 165                                          y-%offset%)
 166                    tz k)
 167                   (setf kp1 (f2cl-lib:int-add k 1))
 168                   (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 169                                 ((> j n) nil)
 170                     (tagbody
 171                      label160
 172                       (setf (f2cl-lib:fref qr-%data%
 173                                            (j kp1)
 174                                            ((1 n) (1 (f2cl-lib:int-add n 1)))
 175                                            qr-%offset%)
 176                               (*
 177                                (f2cl-lib:fref y-%data%
 178                                               (1)
 179                                               ((1 (f2cl-lib:int-add n 1)))
 180                                               y-%offset%)
 181                                (f2cl-lib:fref tz-%data%
 182                                               (j)
 183                                               ((1 (f2cl-lib:int-add n 1)))
 184                                               tz-%offset%)))))
 185                  label170
 186                   (setf (f2cl-lib:fref qr-%data%
 187                                        (k kp1)
 188                                        ((1 n) (1 (f2cl-lib:int-add n 1)))
 189                                        qr-%offset%)
 190                           (+
 191                            (- 1.0f0
 192                               (f2cl-lib:fref y-%data%
 193                                              (1)
 194                                              ((1 (f2cl-lib:int-add n 1)))
 195                                              y-%offset%))
 196                            (f2cl-lib:fref qr-%data%
 197                                           (k kp1)
 198                                           ((1 n) (1 (f2cl-lib:int-add n 1)))
 199                                           qr-%offset%))))))))))
 200      label210
 201       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 202           (dcpose n n qr alpha pivot ierr tz yp)
 203         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6 var-7))
 204         (setf ierr var-5))
 205       (if (= ierr 0) (go label220))
 206       (setf iflag 4)
 207       (go end_label)
 208      label220
 209       (setf (f2cl-lib:fref tz-%data%
 210                            (np1)
 211                            ((1 (f2cl-lib:int-add n 1)))
 212                            tz-%offset%)
 213               (coerce 1.0f0 'double-float))
 214       (f2cl-lib:fdo (lw 1 (f2cl-lib:int-add lw 1))
 215                     ((> lw n) nil)
 216         (tagbody
 217           (setf i (f2cl-lib:int-sub np1 lw))
 218           (setf ik (f2cl-lib:int-add i 1))
 219           (setf sum (coerce 0.0f0 'double-float))
 220           (f2cl-lib:fdo (j ik (f2cl-lib:int-add j 1))
 221                         ((> j np1) nil)
 222             (tagbody
 223              label230
 224               (setf sum
 225                       (+ sum
 226                          (*
 227                           (f2cl-lib:fref qr-%data%
 228                                          (i j)
 229                                          ((1 n) (1 (f2cl-lib:int-add n 1)))
 230                                          qr-%offset%)
 231                           (f2cl-lib:fref tz-%data%
 232                                          (j)
 233                                          ((1 (f2cl-lib:int-add n 1)))
 234                                          tz-%offset%))))))
 235          label240
 236           (setf (f2cl-lib:fref tz-%data%
 237                                (i)
 238                                ((1 (f2cl-lib:int-add n 1)))
 239                                tz-%offset%)
 240                   (/ (- sum)
 241                      (f2cl-lib:fref alpha-%data%
 242                                     (i)
 243                                     ((1 n))
 244                                     alpha-%offset%)))))
 245       (setf ypnorm (dnrm2 np1 tz 1))
 246       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 247                     ((> k np1) nil)
 248         (tagbody
 249           (setf kpiv
 250                   (f2cl-lib:fref pivot-%data%
 251                                  (k)
 252                                  ((1 (f2cl-lib:int-add n 1)))
 253                                  pivot-%offset%))
 254          label260
 255           (setf (f2cl-lib:fref yp-%data%
 256                                (kpiv)
 257                                ((1 (f2cl-lib:int-add n 1)))
 258                                yp-%offset%)
 259                   (/
 260                    (f2cl-lib:fref tz-%data%
 261                                   (k)
 262                                   ((1 (f2cl-lib:int-add n 1)))
 263                                   tz-%offset%)
 264                    ypnorm))))
 265       (if (>= (ddot np1 yp 1 ypold 1) 0.0f0) (go label280))
 266       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 267                     ((> i np1) nil)
 268         (tagbody
 269          label270
 270           (setf (f2cl-lib:fref yp-%data%
 271                                (i)
 272                                ((1 (f2cl-lib:int-add n 1)))
 273                                yp-%offset%)
 274                   (-
 275                    (f2cl-lib:fref yp-%data%
 276                                   (i)
 277                                   ((1 (f2cl-lib:int-add n 1)))
 278                                   yp-%offset%)))))
 279      label280
 280       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 281                     ((> i np1) nil)
 282         (tagbody
 283          label290
 284           (setf (f2cl-lib:fref ypold-%data%
 285                                (i)
 286                                ((1 (f2cl-lib:int-add n 1)))
 287                                ypold-%offset%)
 288                   (f2cl-lib:fref yp-%data%
 289                                  (i)
 290                                  ((1 (f2cl-lib:int-add n 1)))
 291                                  yp-%offset%))))
 292       (go end_label)
 293      end_label
 294       (return
 295        (values nil nil nil nil nil nil nil nil nil nfe nil iflag nil nil)))))
 296
 297 (in-package #:cl-user)
 298 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 299 (eval-when (:load-toplevel :compile-toplevel :execute)
 300   (setf (gethash 'fortran-to-lisp::fode fortran-to-lisp::*f2cl-function-info*)
 301           (fortran-to-lisp::make-f2cl-finfo
 302            :arg-types '((double-float) (array double-float (*))
 303                         (array double-float (*)) (array double-float (*))
 304                         (array double-float (*)) (array double-float (*))
 305                         (array double-float (*)) (array double-float (*))
 306                         (array fortran-to-lisp::integer4 (*))
 307                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 308                         (fortran-to-lisp::integer4) (array double-float (*))
 309                         (array fortran-to-lisp::integer4 (*)))
 310            :return-values '(nil nil nil nil nil nil nil nil nil
 311                             fortran-to-lisp::nfe nil fortran-to-lisp::iflag nil
 312                             nil)
 313            :calls '(fortran-to-lisp::fjac fortran-to-lisp::f
 314                     fortran-to-lisp::ddot fortran-to-lisp::dnrm2
 315                     fortran-to-lisp::dcpose fortran-to-lisp::rhojac))))
 316