C	PROGRAM IBCD.FT
C	--------------
C
C
C
C
C	AN OS/8 FORTRAN II FUNCTION TO DO BCD NUMBER CONVERSION
C	---------------------------------------------------------
C
C
C
C
	FUNCTION IBCD(I,IOPR)
C
C
C
C
C	PETER LEMKIN
C	NATIONAL INSTITIUTE OF HEALTH
C	BETHESDA  MARYLAND   20014
C
C
C	JULY 6, 1972
C	REVISED DECEMBER 4, 1972
C
C
C
C
C
C
C	ABSTRACT
C	-------
C	"IBCD" PACKS OR UNPACKS A BCD WORD (3 4BIT BYTES)
C	FROM OR TO A FORTRAN INTEGER. THE WORD TO BE PACKED
C	OR UNPACKED IS GIVEN IN ARGUMENT "I" WHILE THE RESULT
C	IS RETURNED IN "IBCD".
C	**PAGE
C
C
C
C	ARGUMENTS
C	---------
C	1. I - THE DATA TO BE PACKED OR UNPACKED.
C	2. IOPR - A SWITCH USED TO DETERMINE PACKING.
C	       IOPR=0 TO UNPACK BCD TO DECIMAL.
C		IOPR=-1 TO PACK DECIMAL TO BCD.
C	3. IBCD - THE RESULT OF PACKING OR UNPACKING.
C
C
C
C	1. DETERMINE WHETHER PACK OR UNPACK.
	IF(IOPR)30,20,20
C
C
C
C
C	2. UNPACK "I" INTO IBCD (BCD TO DECIMAL).

S\20,	TAD I \I    /GET LOW BYTE.
S	AND (0017
S	DCA \KSAVE   /SAVE THE LOW BYTE.
C
C
C
C	2.1 GET THE MIDDLE BYTE.
S	TAD I \I    /GET MIDDLE BYTE.
S	RTR;RTR
S	AND (0017
S	DCA \KMID /SAVE THE MIDDLE BYTE.
	KSAVE=KSAVE+(10*KMID)
C
C
C
C	2.2 GET THE TOP BYTE.
S	TAD I \I   /GET TOP BYTE.
S	RTR;RTR;RTR;RTR /MOVE IT TO LOW BYTE POSITION.
S	AND (0017
S	DCA \KTOP
	IBCD=KSAVE+(100*KTOP)
	RETURN
C
C
C
C
C	3. PACK "I" INTO IBCD (DECIMAL TO BCD).
30	IF(I-999)31,33,32
31	IF(I)32,33,33
32	WRITE(ITTY,321)I
321	FORMAT('OVERFLOW ON IBCD=',I5)
	IBCD=0
	RETURN
33	K1=I/100
	K11=K1*100
	K2=(I-K11)/10
	K22=K2*10
	K3=I-K11-K22
S	TAD \K1  /GET HIGH BYTE.
S	RTR;RTR;RAR  /MOVE INTO HIGH BYTE.
S	AND (7400
S	DCA \KSAVE
S	TAD \K2   /GET MIDDLE BYTE.
S	RTL;RTL
S	AND (0360
S	TAD \KSAVE
S	TAD \K3   /ADD ON LOW BYTE.
S	DCA \KSAVE
	IBCD=KSAVE
	RETURN
	END