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 ':simple-array)
14;;;           (:array-slicing nil) (:declare-common nil)
15;;;           (:float-format double-float))
16
17(in-package :slatec)
18
19
20(let* ((newlin "$$"))
21  (declare (type (simple-string 2) newlin) (ignorable newlin))
22  (defun xerprn (prefix npref messg nwrap)
23    (declare (type (f2cl-lib:integer4) nwrap npref)
24             (type (simple-string *) messg prefix))
25    (prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0)
26           (cbuff
27            (make-array '(148) :element-type 'character :initial-element #\ ))
28           (idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0)
29           (n 0))
30      (declare (type (simple-array f2cl-lib:integer4 (5)) iu)
31               (type (f2cl-lib:integer4) n i lpref lwrap lenmsg nextc lpiece
32                                         idelta nunit)
33               (type (simple-string 148) cbuff))
34      (multiple-value-bind (var-0 var-1)
35          (xgetua iu nunit)
36        (declare (ignore var-0))
37        (setf nunit var-1))
38      (setf n (f2cl-lib:i1mach 4))
39      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
40                    ((> i nunit) nil)
41        (tagbody
42          (if (= (f2cl-lib:fref iu (i) ((1 5))) 0)
43              (setf (f2cl-lib:fref iu (i) ((1 5))) n))
44         label10))
45      (cond
46        ((< npref 0)
47         (setf lpref (f2cl-lib:len prefix)))
48        (t
49         (setf lpref npref)))
50      (setf lpref
51              (min (the f2cl-lib:integer4 16) (the f2cl-lib:integer4 lpref)))
52      (if (/= lpref 0)
53          (f2cl-lib:fset-string (f2cl-lib:fref-string cbuff (1 lpref)) prefix))
54      (setf lwrap
55              (max (the f2cl-lib:integer4 16)
56                   (the f2cl-lib:integer4
57                        (min (the f2cl-lib:integer4 132)
58                             (the f2cl-lib:integer4 nwrap)))))
59      (setf lenmsg (f2cl-lib:len messg))
60      (setf n lenmsg)
61      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
62                    ((> i n) nil)
63        (tagbody
64          (if
65           (f2cl-lib:fstring-/= (f2cl-lib:fref-string messg (lenmsg lenmsg))
66                                " ")
67           (go label30))
68          (setf lenmsg (f2cl-lib:int-sub lenmsg 1))
69         label20))
70     label30
71      (cond
72        ((= lenmsg 0)
73         (f2cl-lib:fset-string
74          (f2cl-lib:fref-string cbuff ((+ lpref 1) (f2cl-lib:int-add lpref 1)))
75          " ")
76         (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
77                       ((> i nunit) nil)
78           (tagbody
79             (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5)))
80                               (t (("~A")) "~%")
81                               (f2cl-lib:fref-string cbuff
82                                                     (1
83                                                      (f2cl-lib:int-add lpref
84                                                                        1))))
85            label40))
86         (go end_label)))
87      (setf nextc 1)
88     label50
89      (setf lpiece
90              (f2cl-lib:index (f2cl-lib:fref-string messg (nextc lenmsg))
91                              newlin))
92      (cond
93        ((= lpiece 0)
94         (tagbody
95           (setf idelta 0)
96           (setf lpiece
97                   (min (the f2cl-lib:integer4 lwrap)
98                        (the f2cl-lib:integer4
99                             (f2cl-lib:int-sub (f2cl-lib:int-add lenmsg 1)
100                                               nextc))))
101           (cond
102             ((< lpiece (f2cl-lib:int-add lenmsg 1 (f2cl-lib:int-sub nextc)))
103              (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1)
104                             (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
105                            ((> i 2) nil)
106                (tagbody
107                  (cond
108                    ((f2cl-lib:fstring-=
109                      (f2cl-lib:fref-string messg
110                                            ((+ nextc i (f2cl-lib:int-sub 1))
111                                             (f2cl-lib:int-add nextc
112                                                               i
113                                                               (f2cl-lib:int-sub
114                                                                1))))
115                      " ")
116                     (setf lpiece (f2cl-lib:int-sub i 1))
117                     (setf idelta 1)
118                     (go label54)))
119                 label52))))
120          label54
121           (f2cl-lib:fset-string
122            (f2cl-lib:fref-string cbuff
123                                  ((+ lpref 1)
124                                   (f2cl-lib:int-add lpref lpiece)))
125            (f2cl-lib:fref-string messg
126                                  (nextc
127                                   (f2cl-lib:int-sub
128                                    (f2cl-lib:int-add nextc lpiece)
129                                    1))))
130           (setf nextc (f2cl-lib:int-add nextc lpiece idelta))))
131        ((= lpiece 1)
132         (setf nextc (f2cl-lib:int-add nextc 2))
133         (go label50))
134        ((> lpiece (f2cl-lib:int-add lwrap 1))
135         (tagbody
136           (setf idelta 0)
137           (setf lpiece lwrap)
138           (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1)
139                          (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
140                         ((> i 2) nil)
141             (tagbody
142               (cond
143                 ((f2cl-lib:fstring-=
144                   (f2cl-lib:fref-string messg
145                                         ((+ nextc i (f2cl-lib:int-sub 1))
146                                          (f2cl-lib:int-add nextc
147                                                            i
148                                                            (f2cl-lib:int-sub
149                                                             1))))
150                   " ")
151                  (setf lpiece (f2cl-lib:int-sub i 1))
152                  (setf idelta 1)
153                  (go label58)))
154              label56))
155          label58
156           (f2cl-lib:fset-string
157            (f2cl-lib:fref-string cbuff
158                                  ((+ lpref 1)
159                                   (f2cl-lib:int-add lpref lpiece)))
160            (f2cl-lib:fref-string messg
161                                  (nextc
162                                   (f2cl-lib:int-sub
163                                    (f2cl-lib:int-add nextc lpiece)
164                                    1))))
165           (setf nextc (f2cl-lib:int-add nextc lpiece idelta))))
166        (t
167         (setf lpiece (f2cl-lib:int-sub lpiece 1))
168         (f2cl-lib:fset-string
169          (f2cl-lib:fref-string cbuff
170                                ((+ lpref 1) (f2cl-lib:int-add lpref lpiece)))
171          (f2cl-lib:fref-string messg
172                                (nextc
173                                 (f2cl-lib:int-sub
174                                  (f2cl-lib:int-add nextc lpiece)
175                                  1))))
176         (setf nextc (f2cl-lib:int-add nextc lpiece 2))))
177      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
178                    ((> i nunit) nil)
179        (tagbody
180          (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5)))
181                            (t (("~A")) "~%")
182                            (f2cl-lib:fref-string cbuff
183                                                  (1
184                                                   (f2cl-lib:int-add lpref
185                                                                     lpiece))))
186         label60))
187      (if (<= nextc lenmsg) (go label50))
188      (go end_label)
189     end_label
190      (return (values nil nil nil nil)))))
191
192(in-package #-gcl #:cl-user #+gcl "CL-USER")
193#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
194(eval-when (:load-toplevel :compile-toplevel :execute)
195  (setf (gethash 'fortran-to-lisp::xerprn
196                 fortran-to-lisp::*f2cl-function-info*)
197          (fortran-to-lisp::make-f2cl-finfo
198           :arg-types '((fortran-to-lisp::a nil) (fortran-to-lisp::integer4)
199                        (fortran-to-lisp::a nil) (fortran-to-lisp::integer4))
200           :return-values '(nil nil nil nil)
201           :calls '(fortran-to-lisp::i1mach fortran-to-lisp::xgetua))))
202
203