Commit eacbeac8 authored by rtoy's avatar rtoy

Original version.

parent d03883c1
Fortran to Lisp Translation: installation instructions
------------------------------------------------------
1. Go to the f2cl source directory.
2. Use the target Common Lisp compiler to compile each of the files
f2cl1.l through f2cl7.l and macros.l .
3. Edit the file f2cl0.l to reflect the root directory of the
f2cl file system (*f2cl_dir*) and the extension for your Common
Lisp compiled code (*ext*).
4. Load f2cl0.l into Common Lisp.
5. The translator functions are now available to be used.
6. Important note: when compiling or executing translated code the macros
in the file macros.l should be available.
For more information about f2cl, including user instructions, read the
article f2cldoc.* in the f2cl/doc directory or the tests in f2cl/val.
Bugs and comments: senac@waikato.ac.nz
--------------------------------------------------------------------
This diff is collapsed.
; f2cl0.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; edit here so that the root of the f2cl directory tree is appropriate
; for your installation and the filename extension is valid
#+(or sparc sun4)(defvar *f2cl_dir* "/d/sen/f2cl/wrk/")
#+vms (defvar *f2cl_dir* "d:[sen.f2cl.wrk]")
(defvar *ext*
#+clisp ".fas" #+allegro ".fasl" #+vms ".fas" #+lucid ".sbin")
(defun load-f2cl (x)
(load (concatenate 'string *f2cl_dir* x *ext*) :print nil :verbose t))
(load-f2cl "f2cl1" )
(load-f2cl "f2cl2" )
(load-f2cl "f2cl3" )
(load-f2cl "f2cl4" )
(load-f2cl "f2cl5" )
(load-f2cl "f2cl6" )
(load-f2cl "f2cl7" )
(load-f2cl "macros" )
(format t "~&The f2cl software has been loaded.~%")
;-------------------------------------------------------------------------
; end of f2cl0.l
This diff is collapsed.
This diff is collapsed.
; f2cl3.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;Hamilton, New Zeland 1992-95 - all rights reserved;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; pattern matching for the syntax checker
; functions:
; restrict-test
; exact-match
; match-atoms
; match-atoms-lists
; match-store-atoms
; match-store - for atoms and lists
; match-restrict - restricts atoms and matches for lists
; - to use insert (restrict >var predicate) instead of >var or >
; atomcar, atomcdr
; match-separated - matches (a1 s1 a2 s2 ...... an) where the si are
; separators , it delivers a list of two lists, the first being
; a list of lists of the ai and the second a list of the separators
; or returns nil if an ai is missing - this could be used to
; produce a syntax error.
;-----------------------------------------------------------------------------
(in-package :user)
;(declare (localf atomcar atomcdr))
(defun sub-string (x index &optional len)
(cond ((null len) (subsequence x (sub1 index) (length x)))
(t (subsequence x (sub1 index) (min (sub1 (+ index len)) (length x)) ))))
(defun match-separated (separators lis)
(prog (ret)
(setq ret (gen-list-split separators lis))
(cond ((member nil (car ret)) (return nil))
(t (return ret)))))
; exact match
(defun exact-match (p d)
(cond ((and (null p) (null d)) t) ; have we reached the end ?
((equal (car p) (car d)) ; check the first elements
; if not the same return nil
(exact-match (cdr p) (cdr d))))) ; recurse if the same
; match ">" against any atom
; we need a preliminary check to return nil if one list is shorter
(defun match-atoms (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil) ; is one list shorter ?
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-atoms (cdr p) (cdr d)))))
; incorporate the feature of allowing "+" to match against any number of atoms
(defun match-atoms-lists (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-atoms-lists (cdr p) (cdr d)))
((equal (car p) '+) ; first element + ?
(cond ((match-atoms-lists (cdr p) (cdr d))) ; drop +
((match-atoms-lists p (cdr d))))))) ; keep +
; bind matched atoms to A etc if the pattern has >A
(defun atomcar (a) (nthchar a 1))
(defun atomcdr (a) (concaten (sub-string (symbol-name a) 2)))
(defun match-store-atoms (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-store-atoms (cdr p) (cdr d)))
((and (equal (atomcar (car p)) '>) ; check for >a
(match-store-atoms (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d)) t) ; bind the pattern variables
; value to the matched atom
((equal (car p) '+)
(cond ((match-store-atoms (cdr p) (cdr d)))
((match-store-atoms p (cdr d)))))))
; bind matched groups of atoms to B if the pattern has +B
; the eval obtains the list of atoms seen so far and the cons adds the atom
; matched at the current level
(defun match-store (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-store (cdr p) (cdr d)))
((and (equal (atomcar (car p)) '>)
(match-store (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d)) t)
((equal (car p) '+)
(cond ((match-store (cdr p) (cdr d)))
((match-store p (cdr d)))))
((equal (atomcar (car p)) '+)
(cond ((match-store (cdr p) (cdr d))
(set (atomcdr (car p)) (list (car d))) t) ; building begins
((match-store p (cdr d))
(set (atomcdr (car p))
(cons (car d) (eval (atomcdr (car p))))) t)))))
(defun restrict-test (predicates argument)
(prog ()
loop
(cond ((null predicates) (return t))) ; all tests t?
(cond ((funcall (car predicates) argument) ; this test t?
(setq predicates (cdr predicates))
(go loop)) ; then repeat
(t (return nil))))) ; else fail
(defun match-restrict (p d)
(cond
((and (null p) (null d)) t)
((or (null p) (null d)) nil)
; restricted >
((and (not (atom (car p)))
(equal (caar p) 'restrict)
(equal (cadar p) '>)
(restrict-test (cddar p) (car d)))
(match-restrict (cdr p) (cdr d)))
; restricted >var
((and (not (atom (car p)))
(equal (caar p) 'restrict)
(equal (atomcar (cadar p)) '>)
(restrict-test (cddar p) (car d))
(match-restrict (cdr p) (cdr d)))
(set (atomcdr (cadar p)) (car d))
t)
; equality or >
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-restrict (cdr p) (cdr d)))
; >var
((and (atom (car p))
(equal (atomcar (car p)) '>)
(match-restrict (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d))
t)
; +
((equal (car p) '+)
(cond ((match-restrict (cdr p) (cdr d)))
((match-restrict p (cdr d)))))
; +var
((and (atom (car p)) (equal (atomcar (car p)) '+))
(cond ((match-restrict (cdr p) (cdr d))
(set (atomcdr (car p)) (list (car d)))
t)
((match-restrict p (cdr d))
(set (atomcdr (car p))
(cons (car d) (eval (atomcdr (car p)))))
t)))))
;------------------------------------------------------------------------------
; end of f2cl3.l
; f2cl4.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------------
; functions:
; id-logical
; id-logical-and
; id-logical-not
; id-relational
; memberq
;-----------------------------------------------------------------------------
(in-package :user)
(defun memberq (x l) (member x l :test #'eq))
(defun id-logical (l)
(cond ((member 'or l)
`(or ,@(mapcar #'id-logical-and (list-split-multi 'or l))))
(t (id-logical-and l))))
(defun id-logical-and (l)
(cond ((member 'and l)
`(and ,@(mapcar #'id-logical-not (list-split-multi 'and l))))
(t (id-logical-not l))))
(defun id-logical-not (l)
(cond ((equal (car l) 'not)
`(not ,(id-relational (cdr l))))
(t (id-relational l))))
;----------------------------------------------------------------------------
(defun id-relational (l)
(prog (lhs rhs tmplist)
(return
(cond
; true and false
((equal l '(true)) t)
((equal l '(false)) nil)
; bracketed logical expression:
((and (listp (car l)) (null (cdr l)))
(id-logical (car l)))
; logical equivalence
((memberq 'logeqv l)
(setq tmplist (list-split 'logeqv l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(logeqv ,lhs ,rhs))
; logical non-equivalence
((memberq 'logxor l)
(setq tmplist (list-split 'logxor l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(logxor ,lhs ,rhs))
; greater than or equal:
((memberq '|>=| l)
(setq tmplist (list-split '|>=| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(>= ,lhs ,rhs))
; less than or equal:
((memberq '|<=| l)
(setq tmplist (list-split '|<=| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(<= ,lhs ,rhs))
; equality:
((memberq 'EQUAL l)
(setq tmplist (list-split-bin 'EQUAL l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(= ,lhs ,rhs))
; not equal:
((memberq '|><| l)
(setq tmplist (list-split '|><| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(/= ,lhs ,rhs))
; less than:
((memberq '< l)
(setq tmplist (list-split-bin '< l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(< ,lhs ,rhs))
; greater than:
((memberq '> l)
(setq tmplist (list-split-bin '> l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(> ,lhs ,rhs))
; bracketed logical:
((and (listp (car l)) (null (cdr l)))
(id-logical (car l)))
(t
(parse-expression l))
))))
;------------------------------------------------------------------------------
; end of f2cl4.l
This diff is collapsed.
; f2cl6.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Suite of functions for replacing ".EQ.", ".AND." etc with "=", "AND" etc
;; as a preprocessor for fortran-to-lisp.
;; Numbers such as 6. are replaced with 6.0
;; .6 0.6
;; -.6 -0.6
;; 6.D0 6.0D0
;; etc
;; Also replaces x.xE-x with x.xE~x and x.xE+x with x.xEx so that the lisp reader
;; when set to read FORTRAN can cope.
;; Replaces single quotes (') with double quotes (").
;; Comments are removed
; functions:
; preprocess
; adjust_nrs_and_dots
; parse-logl-op
; replace-str
; parse-number
; write-comment-line
;--------------------------------------------------------------------------
(in-package :user)
(eval-when (compile load eval) (proclaim '(special *verbose* *comments*)))
;--------------------------------------------------------------------------
#+xxxx
(defvar intrinsic_function_names
'(int ifix idint real float sngl dble cmplx ichar char aint dint
anint dnint nint idnint iabs abs dabs cabs mod amod dmod isign sign dsign
idim dim ddim dprod max max0 amax1 dmax1 amax0 amax1 min min0 amini dmini
amini min1 len index lge lgt lle llt aimag conjg sqrt dsqrt csqrt
exp dexp cexp log alog dlog clog log10 alog10 dlog10 sin dsin csin
cos dcos ccos tan dtan asin dasin acos dacos atan datan atan2 datan2
sinh dsinh cosh dcosh tanh dtanh))
; global stream input for parse-number:
(defvar *inp* nil)
;---------------------------------------------------------------------------
(defun preprocess (file &key (outfile-name "prep.tmp"))
(prog (inport outport line)
(if *verbose* (format t "~&preprocessing begins ...~%"))
(setq inport (infile file)
outport (outfile outfile-name))
loop
(setq line (read-line inport nil 'EOF))
(when (eq line 'EOF)
(close outport)
(close inport)
(return outfile-name))
(setq line (string-upcase (string-right-trim '(#\Space) line)))
(cond
((string= line "") nil) ; we leave out blank lines
((char-equal (char line 0) '#\C)
(if *comments* (write-comment-line line outport)))
(t (when *verbose* (princ line) (terpri))
(write-line (adjust_nrs (replace_logl_ops line)) outport)))
(go loop)))
;--------------------------------------------------------------------------
(defun write-comment-line (line outport)
(if *verbose*
(format t " COMMENT \"~a\"~%" (string-downcase (subsequence line 1))))
(format outport " COMMENT \"~a\"~%" (string-downcase (subsequence line 1))))
(defun replace_logl_ops (line)
(prog (inport outport char)
(setq inport (make-string-input-stream line)
outport (make-string-output-stream))
loop
(setq char (read-char inport nil 'EOF t))
(cond ((eql char 'EOF)
(return (get-output-stream-string outport)))
((char= char '#\.)
(parse-logl-op inport outport)
(go loop))
(t (write-char char outport)
(go loop)))))
;--------------------------------------------------------------------------
(defun adjust_nrs (line)
(prog (outport char prev-char)
(setq prev-char '#\space
*inp* (make-string-input-stream line)
outport (make-string-output-stream))
loop
(setq char (read-char *inp* nil 'EOF t))
(cond ((eql char 'EOF) )
; check for single quote and pass over all char until next one
((char= char '#\')
(setq prev-char '#\space)
(write-char '#\" outport)
(do ((char (read-char *inp* nil 'EOF t)
(read-char *inp* nil 'EOF t)))
((char= char '#\') (write-char '#\" outport))
(write-char char outport))
(go loop))
; check for non-complex number
((parse-number prev-char char outport)
(setq prev-char '#\space)
(go loop))
(t (write-char char outport)
(if (digit-char-p char)
(setq prev-char '#\?)
(setq prev-char char))
(go loop)))
(return (get-output-stream-string outport))))
;------------------------------------------------------------------------------
(defun parse-logl-op (inport outport)
(prog (str nxt-char logl-op)
(setq nxt-char (peek-char nil inport nil 'EOF t))
(if (or (member nxt-char `(EOF #\space #\' #\.))
(digit-char-p nxt-char))
(and (write-char '#\. outport)
(return)))
(setq str (make-string-output-stream))
loop
(write-char (read-char inport nil 'EOF t) str)
(setq nxt-char (peek-char nil inport nil 'EOF t))
(if (and (not (eql nxt-char 'EOF))
(char/= nxt-char `#\.)) (go loop))
(cond ((setq str (get-output-stream-string str)
logl-op (replace-str str))
(read-char inport nil 'EOF t) ; read final dot
(write-char '#\space outport)
(write logl-op :stream outport) ; write the converted string with spaces
(write-char '#\space outport))
(t (write-char '#\. outport) ; put the dot back
(write str :stream outport :escape nil))))) ; put everything else back
;------------------------------------------------------------------------------
(defun replace-str (str)
(cond ((equal str "GT") '>)
((equal str "GE") '>=)
((equal str "EQ") 'equal)
((equal str "LE") '<=)
((equal str "LT") '<)
((equal str "NE") '><)
((equal str "NOT") 'NOT)
((equal str "AND") 'AND)
((equal str "OR") 'OR)
((equal str "TRUE") 'TRUE)
((equal str "T") 'TRUE)
((equal str "FALSE") 'FALSE)
((equal str "F") 'FALSE)
((equal str "EQV") 'logeqv)
((equal str "NEQV") 'logxor)
(t nil)))
;------------------------------------------------------------------------------
;inport
(defun parse-number (prev-char char outport)
(prog (str nxt-char)
; first check prev-char suitable to precede a number
(if (not (member prev-char
'(#\newline #\space #\. #\= #\+ #\- #\* #\/ #\( #\, )))
(return nil))
(setq str (make-string-output-stream))
; examine first char and peek at second to ascertain this is a number
(setq nxt-char (peek-char nil *inp* nil 'EOF t))
(cond ((and (digit-char-p char)
(or (and (not (equalp nxt-char 'EOF))
(digit-char-p nxt-char))
(member nxt-char '(#\. #\D #\E))))
(write-char char str) )
((and (or (char= char '#\+) (char= char '#\-))
(char= nxt-char '#\.))
(write-char char str) (write-char '#\0 str) )
((and (or (char= char '#\+) (char= char '#\-))
(digit-char-p nxt-char))
(write-char char str))
((and (char= char '#\.) (digit-char-p nxt-char))
(write-char '#\0 str) (write-char '#\. str) )
(t (return nil)))
; parse rest of number;EOF
loop
(setq char (read-char *inp* nil 'EOF t)
nxt-char (peek-char nil *inp* nil 'EOF t))
(if (eql nxt-char 'EOF) (setq nxt-char `#\space))
(cond ((eql char 'EOF)
(write (get-output-stream-string str) :stream outport :escape nil)
(write-char '#\space outport)
(return t))
((digit-char-p char)
(write-char char str)
(go loop))
((and (char= char '#\.) (not (or (digit-char-p nxt-char)
(char= nxt-char '#\D)
(char= nxt-char '#\E))))
(write-char '#\. str) (write-char '#\0 str)
(write (get-output-stream-string str) :stream outport :escape nil)
(write-char '#\space outport)
(return t))
((and (char= char '#\.) (digit-char-p nxt-char))
(write-char '#\. str)
(go loop))
((and (char= char '#\.) (not (digit-char-p nxt-char)))
(write-char '#\. str) (write-char '#\0 str)
(go loop))
((char= char '#\E)
(write-char '#\e str)
(cond ((char= nxt-char '#\+) (read-char *inp* nil 'EOF t))
((char= nxt-char '#\-) (read-char *inp* nil 'EOF t)
(write-char '#\% str)))
(go loop))
((char= char '#\D)
(write-char '#\d str)
(go loop))
((or (char= char '#\-) (char= char '#\+))
(write-char char str)
(go loop))
(t ;number complete
#+clisp
(if (equal (peek-char nil *inp* nil 'EOF t) 'EOF)
(setq *inp* (make-string-input-stream (string char)))
(setq *inp*
(make-string-input-stream
(concatenate 'string (string char) (read-line *inp*)))))
#-clisp (unread-char char *inp*)
(write (get-output-stream-string str) :stream outport :escape nil)
(write-char '#\space outport)
(return t)))))
;-----------------------------------------------------------------------------
; end of f2cl6.l
; f2cl7.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; optimization post processing phase
; functions:
; find-go-labels
; count-go-end
; labelp
; find-all-labels
; remove-from-tree
; prune-labels
; cond-remove-end-label
(defvar *prune_labels* t)
(eval-when (compile load eval) (proclaim '(special *verbose*)))
;-----------------------------------------------------------------------
(defun find-go-labels (x)
(cond
((atom x) nil)
((eq (car x) 'go) (cons (cadr x) (find-go-labels (cdr x))))
(t (append (find-go-labels (car x))
(find-go-labels (cdr x))))))
;-----------------------------------------------------------------------
(defun count-go-end (x)
(cond
((atom x) 0)
((equal x '(go end_label)) 1)
(t (+ (count-go-end (car x))
(count-go-end (cdr x))))))
;-----------------------------------------------------------------------
(defun labelp (x) (and (symbolp x) (eq 5 (string-lessp "LABEL" (string x)))))
;------------------------------------------------------------------------
(defun find-all-labels (x)
(cond
((atom x) nil)
((labelp (car x)) (cons (car x) (find-all-labels (cdr x))))
(t (append (find-all-labels (car x))
(find-all-labels (cdr x))))))
;-----------------------------------------------------------------------
(defun remove-from-tree (s tree) ; s must be a symbol
(setq tree (if (atom tree) tree (remove s tree :test #'eq)))
(mapcar #'(lambda (y) (if (atom y) y (remove-from-tree s y))) tree))
;-----------------------------------------------------------------------
(defun prune-labels (fun)
(if *verbose* (format t "post-processing begins ...~%"))
(if *prune_labels*
(let* ((labels (find-all-labels fun))
(golabels (find-go-labels fun))
(spare-labels (set-difference labels golabels)))
(setq fun (cond-remove-end-label fun))
(dolist (s spare-labels fun)
(setq fun (remove-from-tree s fun))))
fun))
;-----------------------------------------------------------------------
; If "(go end_label)" appears just once in a subroutine the second and
; third to last exprs of the subroutine are removed if (go end_label)
; is third to last expr.
; Also if "(go end_label)" does not apprear in the subroutine "end_label"
; is removed.
(defun cond-remove-end-label (fun)
(let* ((name (second fun))
(args (third fun))
(body (nthcdr 3 fun))
(rbody (reverse body)))
(setq body
(cond ((zerop (count-go-end body))
(remove 'end_label body))
((and (equal (third rbody) '(go end_label))
(= (count-go-end body) 1))
(reverse (cons (car rbody) (cdddr rbody))))
(t body)))
`(defun ,name ,args ,@body)))
;-----------------------------------------------------------------------
(defun find-declarations (fun)
(remove nil
(mapcar
#'(lambda (x) (if (and (listp x) (or (eq (car x) 'declare)
(eq (car x) 'proclaim)))
x nil))
fun)))
;-----------------------------------------------------------------------
; end of f2cl7.l
This diff is collapsed.
This directory contains some files used for testing f2cl as it developed.
Some of the files test specifics (as indicated by the file name), other
files contain assorted pieces of code from various sources.
The test file collection is not comprehensive.
C A NAG subroutine - contains arithmetic IFs
C
INTEGER FUNCTION H02BAZ(U,V)
C NAG COPYRIGHT 1975
C MARK 4.5 REVISED
C MARK 11.5(F77) REVISED. (SEPT 1985.)
C .. Scalar Arguments ..
INTEGER U, V
C .. Local Scalars ..
INTEGER W
C .. Executable Statements ..
W = U/V
20 IF (W*V-U) 60, 60, 40
40 W = W - 1
GO TO 20
60 IF ((W+1)*V-U) 80, 80, 100
80 W = W + 1
GO TO 60
100 H02BAZ = W
RETURN
END
C Test file for common block translations - adapted from mi10mach.for