1;;; Compiled by f2cl version: 2;;; ("f2cl1.l,v 1.221 2010/05/26 19:25:52 rtoy Exp $" 3;;; "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $" 4;;; "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $" 5;;; "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $" 6;;; "f2cl5.l,v 1.204 2010/02/23 05:21:30 rtoy Exp $" 7;;; "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $" 8;;; "macros.l,v 1.114 2010/05/17 01:42:14 rtoy Exp $") 9 10;;; Using Lisp CMU Common Lisp CVS Head 2010-05-25 18:21:07 (20A 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 :colnew) 18 19 20(defun gderiv (gi nrow irow zval dgz mode dgsub) 21 (declare (type (array double-float (*)) dgz zval) 22 (type (f2cl-lib:integer4) mode irow nrow) 23 (type (array double-float (*)) gi)) 24 (let () 25 (symbol-macrolet ((mstar (aref (colord-part-0 *colord-common-block*) 2)) 26 (izeta (aref (colsid-part-1 *colsid-common-block*) 0)) 27 (nonlin (aref (colnln-part-0 *colnln-common-block*) 0)) 28 (iter (aref (colnln-part-0 *colnln-common-block*) 1))) 29 (f2cl-lib:with-multi-array-data 30 ((gi double-float gi-%data% gi-%offset%) 31 (zval double-float zval-%data% zval-%offset%) 32 (dgz double-float dgz-%data% dgz-%offset%)) 33 (prog ((dot 0.0) (j 0) 34 (dg (make-array 40 :element-type 'double-float))) 35 (declare (type (array double-float (40)) dg) 36 (type (f2cl-lib:integer4) j) 37 (type double-float dot)) 38 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 39 ((> j mstar) nil) 40 (tagbody label10 (setf (f2cl-lib:fref dg (j) ((1 40))) 0.0))) 41 (multiple-value-bind (var-0 var-1 var-2) 42 (funcall dgsub izeta zval dg) 43 (declare (ignore var-1 var-2)) 44 (when var-0 45 (setf izeta var-0))) 46 (if (or (= nonlin 0) (> iter 0)) (go label30)) 47 (setf dot 0.0) 48 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 49 ((> j mstar) nil) 50 (tagbody 51 label20 52 (setf dot 53 (+ dot 54 (* (f2cl-lib:fref dg (j) ((1 40))) 55 (f2cl-lib:fref zval-%data% 56 (j) 57 ((1 1)) 58 zval-%offset%)))))) 59 (setf (f2cl-lib:fref dgz-%data% (izeta) ((1 1)) dgz-%offset%) dot) 60 label30 61 (if (= mode 2) (go label50)) 62 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 63 ((> j mstar) nil) 64 (tagbody 65 (setf (f2cl-lib:fref gi-%data% 66 (irow j) 67 ((1 nrow) (1 1)) 68 gi-%offset%) 69 (f2cl-lib:fref dg (j) ((1 40)))) 70 label40 71 (setf (f2cl-lib:fref gi-%data% 72 (irow (f2cl-lib:int-add mstar j)) 73 ((1 nrow) (1 1)) 74 gi-%offset%) 75 0.0))) 76 (go end_label) 77 label50 78 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 79 ((> j mstar) nil) 80 (tagbody 81 (setf (f2cl-lib:fref gi-%data% 82 (irow j) 83 ((1 nrow) (1 1)) 84 gi-%offset%) 85 0.0) 86 label60 87 (setf (f2cl-lib:fref gi-%data% 88 (irow (f2cl-lib:int-add mstar j)) 89 ((1 nrow) (1 1)) 90 gi-%offset%) 91 (f2cl-lib:fref dg (j) ((1 40)))))) 92 (go end_label) 93 end_label 94 (return (values nil nil nil nil nil nil nil))))))) 95 96(in-package #-gcl #:cl-user #+gcl "CL-USER") 97#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 98(eval-when (:load-toplevel :compile-toplevel :execute) 99 (setf (gethash 'fortran-to-lisp::gderiv 100 fortran-to-lisp::*f2cl-function-info*) 101 (fortran-to-lisp::make-f2cl-finfo 102 :arg-types '((array double-float (*)) (fortran-to-lisp::integer4) 103 (fortran-to-lisp::integer4) (array double-float (1)) 104 (array double-float (1)) (fortran-to-lisp::integer4) t) 105 :return-values '(nil nil nil nil nil nil nil) 106 :calls 'nil))) 107 108