(defun abcon1 (fun c num ierr) (declare (type double-float c)) (declare (type fixnum num)) (declare (type fixnum ierr)) (prog ((right nil) (iend nil) (tol 0.0d0) (xm 0.0d0) (xbar 0.0d0) (dx 0.0d0) (i 0) (x2 0.0d0) (x1 0.0d0) (eta 0.0d0) ) (declare (type t right)) (declare (type t iend)) (declare (type double-float tol)) (declare (type double-float xm)) (declare (type double-float xbar)) (declare (type double-float dx)) (declare (type fixnum i)) (declare (type double-float x2)) (declare (type double-float x1)) (declare (type double-float eta)) (setf eta 0.01) (setf x1 1.01269) (multiple-value-setq (fun x1 right num ierr) (xcond fun x1 right num ierr)) (if (not right) (go label10)) (multiple-value-setq (fun x1 right num1 ierr) (acond fun x1 right num1 ierr)) (setf num (+ num num1)) (if right (go label30)) label10 (setf x2 10.1269) (fdo ((i 1 (+ i 1))) ((> i 4) nil) (tagbody (if (<= x2 x1) (go label10)) (multiple-value-setq (fun x2 right num1 ierr) (xcond fun x2 right num1 ierr) ) (setf num (+ num num1)) (if (not right) (go label20)) (multiple-value-setq (fun x2 right num1 ierr) (acond fun x2 right num1 ierr) ) (setf num (+ num num1)) (if right (go label50)) label20 (setf x1 x2) (setf x2 (* 10.0 x2)) )) (go label100) label30 (setf x2 x1) (setf x1 (- 1.00358)) (fdo ((i 1 (+ i 1))) ((> i 5) nil) (tagbody (multiple-value-setq (fun x1 right num1 ierr) (xcond fun x1 right num1 ierr) ) (setf num (+ num num1)) (if (not right) (go label50)) (multiple-value-setq (fun x1 right num1 ierr) (acond fun x1 right num1 ierr) ) (setf num (+ num num1)) (if (not right) (go label50)) (setf x2 x1) (setf x1 (* 10.0 x1)) )) (go label100) label50 (setf dx (+ x2 (- x1))) (setf xbar (+ x1 (/ dx 2.0))) (setf xm (amax1 (abs x1) (abs x2))) (setf tol eta) (if (> xm 1.0) (setf tol (* eta xm))) (setf iend (<= dx tol)) (multiple-value-setq (fun xbar right num1 ierr) (xcond fun xbar right num1 ierr) ) (setf num (+ num num1)) (if right (go label60)) (if iend (go label80)) (setf x1 xbar) (go label50) label60 (multiple-value-setq (fun xbar right num1 ierr) (acond fun xbar right num1 ierr) ) (setf num (+ num num1)) (if right (go label70)) (if iend (go label80)) (setf x1 xbar) (go label50) label70 (setf x2 xbar) (if (not iend) (go label50)) label80 (setf c x2) (go end_label) label100 (setf c 0.0) (setf ierr 2) (go end_label) end_label (return (values fun c num ierr)) ))