1;;; Compiled by f2cl version:
2;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
3;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
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 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
7;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
8;;;  "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $")
9
10;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C 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 nil) (:declare-common nil)
15;;;           (:float-format double-float))
16
17(in-package :slatec)
18
19
20(let ((con
21       (make-array 2
22                   :element-type 'double-float
23                   :initial-contents '(0.3989422804014327 1.2533141373155003)))
24      (c
25       (make-array 65
26                   :element-type 'double-float
27                   :initial-contents '(-0.208333333333333 0.125
28                                       0.334201388888889 -0.401041666666667
29                                       0.0703125 -1.02581259645062
30                                       1.84646267361111 -0.8912109375
31                                       0.0732421875 4.66958442342625
32                                       -11.207002616223 8.78912353515625
33                                       -2.3640869140625 0.112152099609375
34                                       -28.2120725582002 84.6362176746007
35                                       -91.81824154324 42.5349987453885
36                                       -7.36879435947963 0.227108001708984
37                                       212.570130039217 -765.252468141182
38                                       1059.990452528 -699.579627376133
39                                       218.190511744212 -26.4914304869516
40                                       0.572501420974731 -1919.45766231841
41                                       8061.72218173731 -13586.5500064341
42                                       11655.3933368645 -5305.6469786134
43                                       1200.90291321635 -108.090919788395
44                                       1.72772750258446 20204.2913309661
45                                       -96980.5983886375 192547.001232532
46                                       -203400.177280416 122200.464983017
47                                       -41192.6549688976 7109.51430248936
48                                       -493.915304773088 6.07404200127348
49                                       -242919.187900551 1311763.61466298
50                                       -2998015.91853811 3763271.2976564
51                                       -2813563.22658653 1268365.27332162
52                                       -331645.172484564 45218.7689813627
53                                       -2499.83048181121 24.3805296995561
54                                       3284469.85307204 -1.97068191184322e7
55                                       5.09526024926646e7 -7.41051482115327e7
56                                       6.6344512274729e7 -3.75671766607634e7
57                                       1.32887671664218e7 -2785618.12808645
58                                       308186.404612662 -13886.089753717
59                                       110.017140269247))))
60  (declare (type (array double-float (2)) con)
61           (type (array double-float (65)) c))
62  (defun dasyik (x fnu kode flgik ra arg in y)
63    (declare (type (array double-float (*)) y)
64             (type (f2cl-lib:integer4) in kode)
65             (type (double-float) arg ra flgik fnu x))
66    (f2cl-lib:with-multi-array-data
67        ((y double-float y-%data% y-%offset%))
68      (prog ((ak 0.0) (ap 0.0) (coef 0.0) (etx 0.0) (fn 0.0) (gln 0.0) (s1 0.0)
69             (s2 0.0) (t$ 0.0) (tol 0.0) (t2 0.0) (z 0.0) (j 0) (jn 0) (k 0)
70             (kk 0) (l 0))
71        (declare (type (f2cl-lib:integer4) l kk k jn j)
72                 (type (double-float) z t2 tol t$ s2 s1 gln fn etx coef ap ak))
73        (setf tol (f2cl-lib:d1mach 3))
74        (setf tol (max tol 1.0e-15))
75        (setf fn fnu)
76        (setf z (/ (- 3.0 flgik) 2.0))
77        (setf kk (f2cl-lib:int z))
78        (f2cl-lib:fdo (jn 1 (f2cl-lib:int-add jn 1))
79                      ((> jn in) nil)
80          (tagbody
81            (if (= jn 1) (go label10))
82            (setf fn (- fn flgik))
83            (setf z (/ x fn))
84            (setf ra (f2cl-lib:fsqrt (+ 1.0 (* z z))))
85            (setf gln (f2cl-lib:flog (/ (+ 1.0 ra) z)))
86            (setf etx
87                    (coerce (the f2cl-lib:integer4 (f2cl-lib:int-sub kode 1))
88                            'double-float))
89            (setf t$ (+ (* ra (- 1.0 etx)) (/ etx (+ z ra))))
90            (setf arg (* fn (- t$ gln) flgik))
91           label10
92            (setf coef (exp arg))
93            (setf t$ (/ 1.0 ra))
94            (setf t2 (* t$ t$))
95            (setf t$ (/ t$ fn))
96            (setf t$ (f2cl-lib:sign t$ flgik))
97            (setf s2 1.0)
98            (setf ap 1.0)
99            (setf l 0)
100            (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
101                          ((> k 11) nil)
102              (tagbody
103                (setf l (f2cl-lib:int-add l 1))
104                (setf s1 (f2cl-lib:fref c (l) ((1 65))))
105                (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
106                              ((> j k) nil)
107                  (tagbody
108                    (setf l (f2cl-lib:int-add l 1))
109                    (setf s1 (+ (* s1 t2) (f2cl-lib:fref c (l) ((1 65)))))
110                   label20))
111                (setf ap (* ap t$))
112                (setf ak (* ap s1))
113                (setf s2 (+ s2 ak))
114                (if (< (max (abs ak) (abs ap)) tol) (go label40))
115               label30))
116           label40
117            (setf t$ (abs t$))
118            (setf (f2cl-lib:fref y-%data% (jn) ((1 *)) y-%offset%)
119                    (* s2
120                       coef
121                       (f2cl-lib:fsqrt t$)
122                       (f2cl-lib:fref con (kk) ((1 2)))))
123           label50))
124        (go end_label)
125       end_label
126        (return (values nil nil nil nil ra arg nil nil))))))
127
128(in-package #-gcl #:cl-user #+gcl "CL-USER")
129#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
130(eval-when (:load-toplevel :compile-toplevel :execute)
131  (setf (gethash 'fortran-to-lisp::dasyik
132                 fortran-to-lisp::*f2cl-function-info*)
133          (fortran-to-lisp::make-f2cl-finfo
134           :arg-types '((double-float) (double-float)
135                        (fortran-to-lisp::integer4) (double-float)
136                        (double-float) (double-float)
137                        (fortran-to-lisp::integer4) (array double-float (*)))
138           :return-values '(nil nil nil nil fortran-to-lisp::ra
139                            fortran-to-lisp::arg nil nil)
140           :calls '(fortran-to-lisp::d1mach))))
141
142