src/numerical/slatec/xersve.lisp

   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* ((lentab 10))
  21   (declare (type (f2cl-lib:integer4 10 10) lentab) (ignorable lentab))
  22   (let ((nmsg 0)
  23         (kountx 0)
  24         (kount (make-array lentab :element-type 'f2cl-lib:integer4))
  25         (levtab (make-array lentab :element-type 'f2cl-lib:integer4))
  26         (nertab (make-array lentab :element-type 'f2cl-lib:integer4))
  27         (mestab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (20) nil))
  28         (subtab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (8) nil))
  29         (libtab (f2cl-lib:f2cl-init-string ((+ 1 (- lentab 1))) (8) nil)))
  30     (declare (type (f2cl-lib:integer4) nmsg kountx)
  31              (type (simple-array f2cl-lib:integer4 (*)) kount levtab nertab)
  32              (type (simple-array (string 20) (*)) mestab)
  33              (type (simple-array (string 8) (*)) subtab libtab))
  34     (defun xersve (librar subrou messg kflag nerr level icount)
  35       (declare (type (f2cl-lib:integer4) icount level nerr kflag)
  36                (type (simple-string *) messg subrou librar))
  37       (prog ((mes
  38               (make-array '(20) :element-type 'character :initial-element #\ ))
  39              (lib
  40               (make-array '(8) :element-type 'character :initial-element #\ ))
  41              (sub
  42               (make-array '(8) :element-type 'character :initial-element #\ ))
  43              (lun (make-array 5 :element-type 'f2cl-lib:integer4)) (i 0)
  44              (iunit 0) (kunit 0) (nunit 0))
  45         (declare (type (f2cl-lib:integer4) nunit kunit iunit i)
  46                  (type (simple-string 20) mes)
  47                  (type (simple-string 8) lib sub)
  48                  (type (simple-array f2cl-lib:integer4 (5)) lun))
  49         (cond
  50           ((<= kflag 0)
  51            (if (= nmsg 0) (go end_label))
  52            (multiple-value-bind (var-0 var-1)
  53                (xgetua lun nunit)
  54              (declare (ignore var-0))
  55              (setf nunit var-1))
  56            (f2cl-lib:fdo (kunit 1 (f2cl-lib:int-add kunit 1))
  57                          ((> kunit nunit) nil)
  58              (tagbody
  59                (setf iunit (f2cl-lib:fref lun (kunit) ((1 5))))
  60                (if (= iunit 0) (setf iunit (f2cl-lib:i1mach 4)))
  61                (f2cl-lib:fformat iunit
  62                                  ("0          ERROR MESSAGE SUMMARY" "~%"
  63                                   " LIBRARY    SUBROUTINE MESSAGE START             NERR"
  64                                   "     LEVEL     COUNT" "~%"))
  65                (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  66                              ((> i nmsg) nil)
  67                  (tagbody
  68                    (f2cl-lib:fformat iunit
  69                                      ("~1@T" ("~A") "~3@T" ("~A") "~3@T" ("~A")
  70                                       3 (("~10D")) "~%")
  71                                      (f2cl-lib:fref libtab (i) ((1 lentab)))
  72                                      (f2cl-lib:fref subtab (i) ((1 lentab)))
  73                                      (f2cl-lib:fref mestab (i) ((1 lentab)))
  74                                      (f2cl-lib:fref nertab (i) ((1 lentab)))
  75                                      (f2cl-lib:fref levtab (i) ((1 lentab)))
  76                                      (f2cl-lib:fref kount (i) ((1 lentab))))
  77                   label10))
  78                (if (/= kountx 0)
  79                    (f2cl-lib:fformat iunit
  80                                      ("0OTHER ERRORS NOT INDIVIDUALLY TABULATED = "
  81                                       1 (("~10D")) "~%")
  82                                      kountx))
  83                (f2cl-lib:fformat iunit ("~1@T" "~%"))
  84               label20))
  85            (cond
  86              ((= kflag 0)
  87               (setf nmsg 0)
  88               (setf kountx 0))))
  89           (t
  90            (f2cl-lib:f2cl-set-string lib librar (string 8))
  91            (f2cl-lib:f2cl-set-string sub subrou (string 8))
  92            (f2cl-lib:f2cl-set-string mes messg (string 20))
  93            (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  94                          ((> i nmsg) nil)
  95              (tagbody
  96                (cond
  97                  ((and
  98                    (f2cl-lib:fstring-= lib
  99                                        (f2cl-lib:fref libtab (i) ((1 lentab))))
 100                    (f2cl-lib:fstring-= sub
 101                                        (f2cl-lib:fref subtab (i) ((1 lentab))))
 102                    (f2cl-lib:fstring-= mes
 103                                        (f2cl-lib:fref mestab (i) ((1 lentab))))
 104                    (= nerr (f2cl-lib:fref nertab (i) ((1 lentab))))
 105                    (= level (f2cl-lib:fref levtab (i) ((1 lentab)))))
 106                   (setf (f2cl-lib:fref kount (i) ((1 lentab)))
 107                           (f2cl-lib:int-add
 108                            (f2cl-lib:fref kount (i) ((1 lentab)))
 109                            1))
 110                   (setf icount (f2cl-lib:fref kount (i) ((1 lentab))))
 111                   (go end_label)))
 112               label30))
 113            (cond
 114              ((< nmsg lentab)
 115               (setf nmsg (f2cl-lib:int-add nmsg 1))
 116               (f2cl-lib:f2cl-set-string (f2cl-lib:fref libtab (i) ((1 lentab)))
 117                                         lib
 118                                         (string 8))
 119               (f2cl-lib:f2cl-set-string (f2cl-lib:fref subtab (i) ((1 lentab)))
 120                                         sub
 121                                         (string 8))
 122               (f2cl-lib:f2cl-set-string (f2cl-lib:fref mestab (i) ((1 lentab)))
 123                                         mes
 124                                         (string 20))
 125               (setf (f2cl-lib:fref nertab (i) ((1 lentab))) nerr)
 126               (setf (f2cl-lib:fref levtab (i) ((1 lentab))) level)
 127               (setf (f2cl-lib:fref kount (i) ((1 lentab))) 1)
 128               (setf icount 1))
 129              (t
 130               (setf kountx (f2cl-lib:int-add kountx 1))
 131               (setf icount 0)))))
 132         (go end_label)
 133        end_label
 134         (return (values nil nil nil nil nil nil icount))))))
 135
 136 (in-package #:cl-user)
 137 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 138 (eval-when (:load-toplevel :compile-toplevel :execute)
 139   (setf (gethash 'fortran-to-lisp::xersve
 140                  fortran-to-lisp::*f2cl-function-info*)
 141           (fortran-to-lisp::make-f2cl-finfo
 142            :arg-types '((fortran-to-lisp::a nil) (fortran-to-lisp::a nil)
 143                         (fortran-to-lisp::a nil) (fortran-to-lisp::integer4)
 144                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 145                         (fortran-to-lisp::integer4))
 146            :return-values '(nil nil nil nil nil nil fortran-to-lisp::icount)
 147            :calls '(fortran-to-lisp::i1mach fortran-to-lisp::xgetua))))
 148