share/hompack/lisp/gmfads.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 gmfads (nn a nwk maxa)
  21   (declare (type (array f2cl-lib:integer4 (*)) maxa)
  22            (type (array double-float (*)) a)
  23            (type (f2cl-lib:integer4) nwk nn))
  24   (f2cl-lib:with-multi-array-data
  25       ((a double-float a-%data% a-%offset%)
  26        (maxa f2cl-lib:integer4 maxa-%data% maxa-%offset%))
  27     (prog ((bet 0.0) (del 0.0) (dj 0.0) (g 0.0) (gam 0.0) (gam1 0.0) (phi 0.0)
  28            (the$ 0.0) (the1 0.0) (xt1 0.0) (xt2 0.0) (zet 0.0) (zet1 0.0) (i 0)
  29            (i0 0) (i1 0) (i2 0) (i3 0) (i4 0) (j 0) (j1 0) (k 0) (k1 0) (k2 0)
  30            (kh 0) (kl 0) (kn 0) (ku 0) (kz 0) (l 0) (l1 0) (l2 0) (l3 0) (m 0)
  31            (m1 0) (n1 0) (nnn 0))
  32       (declare (type (f2cl-lib:integer4) nnn n1 m1 m l3 l2 l1 l kz ku kn kl kh
  33                                          k2 k1 k j1 j i4 i3 i2 i1 i0 i)
  34                (type (double-float) zet1 zet xt2 xt1 the1 the$ phi gam1 gam g
  35                                     dj del bet))
  36       (setf g (coerce 0.0f0 'double-float))
  37       (setf gam (coerce 0.0f0 'double-float))
  38       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  39                     ((> i nn) nil)
  40         (tagbody
  41           (setf k
  42                   (f2cl-lib:fref maxa-%data%
  43                                  (i)
  44                                  ((1 (f2cl-lib:int-add nn 1)))
  45                                  maxa-%offset%))
  46           (setf g
  47                   (+ g
  48                      (* (f2cl-lib:fref a-%data% (k) ((1 nwk)) a-%offset%)
  49                         (f2cl-lib:fref a-%data% (k) ((1 nwk)) a-%offset%))))
  50           (setf gam1 (abs (f2cl-lib:fref a-%data% (k) ((1 nwk)) a-%offset%)))
  51           (if (> gam1 gam) (setf gam gam1))
  52          label1))
  53       (setf zet (coerce 0.0f0 'double-float))
  54       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  55                     ((> i nn) nil)
  56         (tagbody
  57           (setf k
  58                   (f2cl-lib:fref maxa-%data%
  59                                  (i)
  60                                  ((1 (f2cl-lib:int-add nn 1)))
  61                                  maxa-%offset%))
  62           (setf k1
  63                   (f2cl-lib:int-sub
  64                    (f2cl-lib:fref maxa-%data%
  65                                   ((f2cl-lib:int-add i 1))
  66                                   ((1 (f2cl-lib:int-add nn 1)))
  67                                   maxa-%offset%)
  68                    1))
  69           (setf k2 (f2cl-lib:int-sub k1 k))
  70           (if (= k2 0) (go label3))
  71           (setf l (f2cl-lib:int-add k 1))
  72           (f2cl-lib:fdo (j l (f2cl-lib:int-add j 1))
  73                         ((> j k1) nil)
  74             (tagbody
  75               (setf g
  76                       (+ g
  77                          (* 2.0f0
  78                             (f2cl-lib:fref a-%data% (j) ((1 nwk)) a-%offset%)
  79                             (f2cl-lib:fref a-%data%
  80                                            (j)
  81                                            ((1 nwk))
  82                                            a-%offset%))))
  83               (setf zet1
  84                       (abs (f2cl-lib:fref a-%data% (j) ((1 nwk)) a-%offset%)))
  85               (if (> zet1 zet) (setf zet zet1))
  86              label2))
  87          label3))
  88       (setf zet (/ zet nn))
  89       (setf del (f2cl-lib:d1mach 4))
  90       (setf bet del)
  91       (if (> zet bet) (setf bet zet))
  92       (if (> gam bet) (setf bet gam))
  93       (setf g (f2cl-lib:fsqrt g))
  94       (if (> g 1.0f0) (setf del (* del g)))
  95       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  96                     ((> i nn) nil)
  97         (tagbody
  98           (setf n1 (f2cl-lib:int-sub i 1))
  99           (setf kn
 100                   (f2cl-lib:fref maxa-%data%
 101                                  (i)
 102                                  ((1 (f2cl-lib:int-add nn 1)))
 103                                  maxa-%offset%))
 104           (setf kl (f2cl-lib:int-add kn 1))
 105           (setf ku
 106                   (f2cl-lib:int-sub
 107                    (f2cl-lib:fref maxa-%data%
 108                                   ((f2cl-lib:int-add i 1))
 109                                   ((1 (f2cl-lib:int-add nn 1)))
 110                                   maxa-%offset%)
 111                    1))
 112           (setf kh (f2cl-lib:int-sub ku kl))
 113           (setf phi (f2cl-lib:fref a-%data% (kn) ((1 nwk)) a-%offset%))
 114           (if (< kh 0) (go label10))
 115           (setf k1 (f2cl-lib:int-add kn 1))
 116           (setf k2 i)
 117           (f2cl-lib:fdo (j k1 (f2cl-lib:int-add j 1))
 118                         ((> j ku) nil)
 119             (tagbody
 120               (setf k2 (f2cl-lib:int-sub k2 1))
 121               (setf kz
 122                       (f2cl-lib:fref maxa-%data%
 123                                      (k2)
 124                                      ((1 (f2cl-lib:int-add nn 1)))
 125                                      maxa-%offset%))
 126               (setf phi
 127                       (+ phi
 128                          (*
 129                           (- (f2cl-lib:fref a-%data% (j) ((1 nwk)) a-%offset%))
 130                           (f2cl-lib:fref a-%data% (j) ((1 nwk)) a-%offset%)
 131                           (f2cl-lib:fref a-%data% (kz) ((1 nwk)) a-%offset%))))
 132              label5))
 133          label10
 134           (setf phi (abs phi))
 135           (setf l (f2cl-lib:int-add i 1))
 136           (setf the$ (coerce 0.0f0 'double-float))
 137           (setf nnn (f2cl-lib:int-add nn 1))
 138           (if (= l nnn) (go label11))
 139           (f2cl-lib:fdo (j l (f2cl-lib:int-add j 1))
 140                         ((> j nn) nil)
 141             (tagbody
 142               (setf l1
 143                       (f2cl-lib:fref maxa-%data%
 144                                      (j)
 145                                      ((1 (f2cl-lib:int-add nn 1)))
 146                                      maxa-%offset%))
 147               (setf l2
 148                       (f2cl-lib:fref maxa-%data%
 149                                      ((f2cl-lib:int-add j 1))
 150                                      ((1 (f2cl-lib:int-add nn 1)))
 151                                      maxa-%offset%))
 152               (setf l3 (f2cl-lib:int-sub l2 l1 1))
 153               (setf m (f2cl-lib:int-sub j i))
 154               (if (< l3 m) (go label6))
 155               (setf m1 (f2cl-lib:int-add l1 m))
 156               (if (= n1 0) (go label7))
 157               (f2cl-lib:fdo (j1 1 (f2cl-lib:int-add j1 1))
 158                             ((> j1 n1) nil)
 159                 (tagbody
 160                   (setf i0
 161                           (f2cl-lib:fref maxa-%data%
 162                                          (j1)
 163                                          ((1 (f2cl-lib:int-add nn 1)))
 164                                          maxa-%offset%))
 165                   (setf i1
 166                           (f2cl-lib:fref maxa-%data%
 167                                          (l)
 168                                          ((1 (f2cl-lib:int-add nn 1)))
 169                                          maxa-%offset%))
 170                   (setf i2 (f2cl-lib:int-sub i j1))
 171                   (setf i3 (f2cl-lib:int-sub i1 kn 1))
 172                   (setf i4 (f2cl-lib:int-sub j j1))
 173                   (if (< i3 i2) (go label8))
 174                   (if (< l3 i4) (go label8))
 175                   (setf xt1
 176                           (f2cl-lib:fref a-%data%
 177                                          ((f2cl-lib:int-add kn i2))
 178                                          ((1 nwk))
 179                                          a-%offset%))
 180                   (setf xt2
 181                           (f2cl-lib:fref a-%data%
 182                                          ((f2cl-lib:int-add l1 i4))
 183                                          ((1 nwk))
 184                                          a-%offset%))
 185                   (setf (f2cl-lib:fref a-%data% (m1) ((1 nwk)) a-%offset%)
 186                           (+ (f2cl-lib:fref a-%data% (m1) ((1 nwk)) a-%offset%)
 187                              (* (- xt1)
 188                                 xt2
 189                                 (f2cl-lib:fref a-%data%
 190                                                (i0)
 191                                                ((1 nwk))
 192                                                a-%offset%))))
 193                  label8))
 194              label7
 195               (setf the1
 196                       (abs (f2cl-lib:fref a-%data% (m1) ((1 nwk)) a-%offset%)))
 197               (if (< the$ the1) (setf the$ the1))
 198              label6))
 199          label11
 200           (setf the$ (/ (* the$ the$) bet))
 201           (setf dj del)
 202           (if (> phi dj) (setf dj phi))
 203           (if (> the$ dj) (setf dj the$))
 204           (setf (f2cl-lib:fref a-%data% (kn) ((1 nwk)) a-%offset%) dj)
 205           (if (= l nnn) (go label4))
 206           (f2cl-lib:fdo (j l (f2cl-lib:int-add j 1))
 207                         ((> j nn) nil)
 208             (tagbody
 209               (setf l1
 210                       (f2cl-lib:fref maxa-%data%
 211                                      (j)
 212                                      ((1 (f2cl-lib:int-add nn 1)))
 213                                      maxa-%offset%))
 214               (setf l2
 215                       (f2cl-lib:fref maxa-%data%
 216                                      ((f2cl-lib:int-add j 1))
 217                                      ((1 (f2cl-lib:int-add nn 1)))
 218                                      maxa-%offset%))
 219               (setf l3 (f2cl-lib:int-sub l2 l1 1))
 220               (setf m (f2cl-lib:int-sub j i))
 221               (if (< l3 m) (go label9))
 222               (setf m1 (f2cl-lib:int-add l1 m))
 223               (setf (f2cl-lib:fref a-%data% (m1) ((1 nwk)) a-%offset%)
 224                       (/ (f2cl-lib:fref a-%data% (m1) ((1 nwk)) a-%offset%)
 225                          (f2cl-lib:fref a-%data% (kn) ((1 nwk)) a-%offset%)))
 226              label9))
 227          label4))
 228       (go end_label)
 229      end_label
 230       (return (values nil nil nil nil)))))
 231
 232 (in-package #:cl-user)
 233 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 234 (eval-when (:load-toplevel :compile-toplevel :execute)
 235   (setf (gethash 'fortran-to-lisp::gmfads
 236                  fortran-to-lisp::*f2cl-function-info*)
 237           (fortran-to-lisp::make-f2cl-finfo
 238            :arg-types '((fortran-to-lisp::integer4) (array double-float (*))
 239                         (fortran-to-lisp::integer4)
 240                         (array fortran-to-lisp::integer4 (*)))
 241            :return-values '(nil nil nil nil)
 242            :calls '(fortran-to-lisp::d1mach))))
 243