1;;; Compiled by f2cl version: 2;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 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 3fe93de3be82 2012/05/06 02:17:14 toy $" 7;;; "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $" 8;;; "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $") 9 10;;; Using Lisp CMU Common Lisp 20d (20D 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 :lapack) 18 19 20(let* ((one 1.0)) 21 (declare (type (double-float 1.0 1.0) one) (ignorable one)) 22 (defun zgebak (job side n ilo ihi scale m v ldv info) 23 (declare (type (array f2cl-lib:complex16 (*)) v) 24 (type (array double-float (*)) scale) 25 (type (f2cl-lib:integer4) info ldv m ihi ilo n) 26 (type (simple-string *) side job)) 27 (f2cl-lib:with-multi-array-data 28 ((job character job-%data% job-%offset%) 29 (side character side-%data% side-%offset%) 30 (scale double-float scale-%data% scale-%offset%) 31 (v f2cl-lib:complex16 v-%data% v-%offset%)) 32 (prog ((s 0.0) (i 0) (ii 0) (k 0) (leftv nil) (rightv nil)) 33 (declare (type (double-float) s) 34 (type (f2cl-lib:integer4) i ii k) 35 (type f2cl-lib:logical leftv rightv)) 36 (setf rightv (lsame side "R")) 37 (setf leftv (lsame side "L")) 38 (setf info 0) 39 (cond 40 ((and (not (lsame job "N")) 41 (not (lsame job "P")) 42 (not (lsame job "S")) 43 (not (lsame job "B"))) 44 (setf info -1)) 45 ((and (not rightv) (not leftv)) 46 (setf info -2)) 47 ((< n 0) 48 (setf info -3)) 49 ((or (< ilo 1) 50 (> ilo 51 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))) 52 (setf info -4)) 53 ((or 54 (< ihi (min (the f2cl-lib:integer4 ilo) (the f2cl-lib:integer4 n))) 55 (> ihi n)) 56 (setf info -5)) 57 ((< m 0) 58 (setf info -7)) 59 ((< ldv (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))) 60 (setf info -9))) 61 (cond 62 ((/= info 0) 63 (xerbla "ZGEBAK" (f2cl-lib:int-sub info)) 64 (go end_label))) 65 (if (= n 0) (go end_label)) 66 (if (= m 0) (go end_label)) 67 (if (lsame job "N") (go end_label)) 68 (if (= ilo ihi) (go label30)) 69 (cond 70 ((or (lsame job "S") (lsame job "B")) 71 (cond 72 (rightv 73 (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i 1)) 74 ((> i ihi) nil) 75 (tagbody 76 (setf s 77 (f2cl-lib:fref scale-%data% 78 (i) 79 ((1 *)) 80 scale-%offset%)) 81 (zdscal m s 82 (f2cl-lib:array-slice v-%data% 83 f2cl-lib:complex16 84 (i 1) 85 ((1 ldv) (1 *)) 86 v-%offset%) 87 ldv) 88 label10)))) 89 (cond 90 (leftv 91 (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i 1)) 92 ((> i ihi) nil) 93 (tagbody 94 (setf s 95 (/ one 96 (f2cl-lib:fref scale-%data% 97 (i) 98 ((1 *)) 99 scale-%offset%))) 100 (zdscal m s 101 (f2cl-lib:array-slice v-%data% 102 f2cl-lib:complex16 103 (i 1) 104 ((1 ldv) (1 *)) 105 v-%offset%) 106 ldv) 107 label20)))))) 108 label30 109 (cond 110 ((or (lsame job "P") (lsame job "B")) 111 (cond 112 (rightv 113 (f2cl-lib:fdo (ii 1 (f2cl-lib:int-add ii 1)) 114 ((> ii n) nil) 115 (tagbody 116 (setf i ii) 117 (if (and (>= i ilo) (<= i ihi)) (go label40)) 118 (if (< i ilo) (setf i (f2cl-lib:int-sub ilo ii))) 119 (setf k 120 (f2cl-lib:int 121 (f2cl-lib:fref scale-%data% 122 (i) 123 ((1 *)) 124 scale-%offset%))) 125 (if (= k i) (go label40)) 126 (zswap m 127 (f2cl-lib:array-slice v-%data% 128 f2cl-lib:complex16 129 (i 1) 130 ((1 ldv) (1 *)) 131 v-%offset%) 132 ldv 133 (f2cl-lib:array-slice v-%data% 134 f2cl-lib:complex16 135 (k 1) 136 ((1 ldv) (1 *)) 137 v-%offset%) 138 ldv) 139 label40)))) 140 (cond 141 (leftv 142 (f2cl-lib:fdo (ii 1 (f2cl-lib:int-add ii 1)) 143 ((> ii n) nil) 144 (tagbody 145 (setf i ii) 146 (if (and (>= i ilo) (<= i ihi)) (go label50)) 147 (if (< i ilo) (setf i (f2cl-lib:int-sub ilo ii))) 148 (setf k 149 (f2cl-lib:int 150 (f2cl-lib:fref scale-%data% 151 (i) 152 ((1 *)) 153 scale-%offset%))) 154 (if (= k i) (go label50)) 155 (zswap m 156 (f2cl-lib:array-slice v-%data% 157 f2cl-lib:complex16 158 (i 1) 159 ((1 ldv) (1 *)) 160 v-%offset%) 161 ldv 162 (f2cl-lib:array-slice v-%data% 163 f2cl-lib:complex16 164 (k 1) 165 ((1 ldv) (1 *)) 166 v-%offset%) 167 ldv) 168 label50)))))) 169 (go end_label) 170 end_label 171 (return (values nil nil nil nil nil nil nil nil nil info)))))) 172 173(in-package #-gcl #:cl-user #+gcl "CL-USER") 174#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 175(eval-when (:load-toplevel :compile-toplevel :execute) 176 (setf (gethash 'fortran-to-lisp::zgebak 177 fortran-to-lisp::*f2cl-function-info*) 178 (fortran-to-lisp::make-f2cl-finfo 179 :arg-types '((simple-string) (simple-string) 180 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 181 (fortran-to-lisp::integer4) (array double-float (*)) 182 (fortran-to-lisp::integer4) 183 (array fortran-to-lisp::complex16 (*)) 184 (fortran-to-lisp::integer4) 185 (fortran-to-lisp::integer4)) 186 :return-values '(nil nil nil nil nil nil nil nil nil 187 fortran-to-lisp::info) 188 :calls '(fortran-to-lisp::zswap fortran-to-lisp::zdscal 189 fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 190 191