C PROGRAM IBCD.FT 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 MARCH 7, 1975 C REVISED OCT 22, 1975 C C PDP8E IOTS NOT DEFINED IN SABER C ------------------------------- S OPDEF CLAMQ 7621 /CLA MQL S OPDEF SWP 7521 S OPDEF BSW 7002 S OPDEF MQL 7421 S OPDEF MQA 7501 S OPDEF MUY 7405 S OPDEF DVI 7407 S OPDEF SHL 7413 /SHIFT LEFT S OPDEF LSR 7417 /LOGICAL SHIFT RIGHT S OPDEF SWAB 7431 /A ==> B (ALSO DOES AN MQL) S OPDEF SWBA 7447 /B ==> A S OPDEF DAD 7443 S OPDEF DST 7445 S OPDEF DPIC 7573 S OPDEF DCM 7575 S OPDEF DPSZ 7451 C C C C PURPOSE 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 "I" WHILE THE RESULT IS IN C "IBCD". C C C C ARGUMENTS C --------- C 1. I - THE DATA TO BE PACKED OR UNPACKED. C C C 2. IOPR - A SWITCH USED TO DETERMINE PACKING. C 0 OR > 0 BCD TO DECIMAL C -1 DEC DECIMAL TO BCD C C 3. IBCD - THE RESULT OF PACKING OR UNPACKING. C C C C C [1] DETERMINE WHETHER PACK OR UNPACK. C FIRST SAVE THE DATA S SWBA /MAKE SURE THAT IN A MODE... K3=I C K2=IOPR S TAD \K2 S SPA CLA /SKIP IF >-1 S JMP \30 /DO DECIMAL TO BCD C C C C C [2] UNPACK "I" INTO IBCD (BCD TO DECIMAL). C GET THE LOW BYTE S TAD \K3 S AND (0017 S DCA \IBCD /SAVE THE LOW BYTE. C C C C [2.1] GET THE MIDDLE BYTE. S TAD \K3 /GET MIDDLE BYTE. S RTR;RTR S AND (0017 S MQL S CPAGE 2 S MUY S 12 /10 DECIMAL S SWP /LOW ORDER TO THE AC S TAD \IBCD S DCA \IBCD C C C C [2.2] GET THE TOP BYTE. S TAD \K3 /GET THE TOP BYTE S BSW; RTR /MOVE IT TO LOW BYTE POSITION. S AND (0017 S MQL S CPAGE 2 S MUY S 144 /(KTOP*100) S SWP S TAD \IBCD S DCA \IBCD 322 RETURN C C C C C [3] PACK "I" INTO IBCD (DECIMAL TO BCD). C TEST IF 1000 > I > -1. S\30, TAD \K3 S SPA S JMP \32 /<0 S TAD (-D1000 /- IF >999 S SPA CLA S JMP \33 /IT IS OK C S\32, CLA WRITE(1,321) 321 FORMAT('BCDOVF') IBCD=0 GOTO 322 C C COMPUTE: K1=I/100 S\33, TAD \K3 S MQL S CPAGE 2 S DVI S 144 /(I/100) S DCA \IREM1 /SAVE THE REMAINDER S MQA /GET THE QUOTIENT S DCA \K1 C C GET THE MIDDLE DIGIT=QUOTIENT (REM(I/100)/10) S TAD \IREM1 S MQL /LOAD THE REMAINDER S CPAGE 2 S DVI S 12 /D((REM(I/100)/10) S DCA \K3 /SAVE LOW BYTE C C C GET THE LOW DIGIT= REM(REM(I/100)/10) S SWP S DCA \K2 /SAVE MIDDLE BYTE C C NOW PACK IN 3 BCD DIGITS S TAD \K1 /GET HIGH BYTE. S BSW; RTL /MOVE INTO HIGH BYTE. S AND (7400 S DCA \IBCD S TAD \K2 /GET MIDDLE BYTE. S RTL;RTL S AND (0360 S TAD \IBCD S TAD \K3 /ADD ON LOW BYTE. S DCA \IBCD GOTO 322 C C DEFINE VARIABLES HERE :NEVER ACCESSED IREM1=0 K1=0 C END