home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
modcomp.zip
/
pack.
< prev
next >
Wrap
Text File
|
1987-01-26
|
5KB
|
137 lines
SUBROUTINE PACK (ALIN,BLIN)
C
C ****************************************************************
C
C KERMIT for the MODCOMP MAXIV operating system
C
C Compliments of:
C
C SETPOINT, Inc.
C 10245 Brecksville Rd.
C Brecksville, Ohio 44141
C
C
C KERMIT is a copyrighted protocol of Columbia Univ. The authors
C of this version hereby grant permission to copy this software
C provided that it is not used for an explicitly commercial
C purpose and that proper credit be given. SETPOINT, Inc. makes
C no warranty whatsoever regarding the accuracy of this package
C and will assume no liability resulting from it's use.
C
C ****************************************************************
C
C Abstract: Pack the INTEGER array ALIN into the array BLIN
C with the right side of the byte ending with a
C BLANK, in case there are an odd number of bytes.
C
C MODIFICATION HISTORY
C
C BY DATE REASON PROGRAMS AFFECTED
C
C ****************************************************************
C
C Author: Rick Burke Version: A.0 Date: Aug-86
C
C Calling Parameters:
C
C R ALIN - Array to be packed
C W BLIN - Packed array to be returned to the user
C
C ****************************************************************
C
C Messages generated by this module : None
C
C ****************************************************************
C
C Subroutines called directly : IAND, IOR, ISHFT
C
C ****************************************************************
C
C Files referenced : None
C
C ****************************************************************
C
C Local variable definitions :
C
C ACOUNT - Index pointer into ALIN
C BCOUNT - Index pointer into BLIN
C LEFT - Symbolic constant for LEFT byte
C RIGHT - Symbolic constant for RIGHT byte
C WHICHS - Indicator for left/right side to be processed
C
C ****************************************************************
C
C Commons referenced : KERPAR local common
C
C ****************************************************************
C
C (*$END.DOCUMENT*)
C
C ****************************************************************
C * *
C * D I M E N S I O N S T A T E M E N T S *
C * *
C ****************************************************************
C
IMPLICIT INTEGER (A-Z)
INTEGER*2 ALIN(1), BLIN(1)
C
C ****************************************************************
C * *
C * T Y P E S T A T E M E N T S *
C * *
C ****************************************************************
C
C
C ****************************************************************
C * *
C * C O M M O N S T A T E M E N T S *
C * *
C ****************************************************************
C
INCLUDE USL/KERPMC
C
C ****************************************************************
C * *
C * E Q U I V A L E N C E S T A T E M E N T S *
C * *
C ****************************************************************
C
C
C ****************************************************************
C * *
C * D A T A S T A T E M E N T S *
C * *
C ****************************************************************
C
DATA LEFT /0/, RIGHT /1/
C
C ****************************************************************
C
C Code starts here :
C
WHICHS = LEFT
ACOUNT = 1
BCOUNT = 1
C
BLIN(1) = 4Z2020
IF (ALIN(ACOUNT) .EQ. LF) GO TO 40
C
C-----> Pack the output line, until LF char is reached.
C
10 CONTINUE
IF (WHICHS .NE. LEFT) GO TO 20
BLIN(BCOUNT) = IOR (ISHFT (ALIN(ACOUNT),8),4Z0020)
WHICHS = RIGHT
GO TO 30
20 CONTINUE
BLIN(BCOUNT) = IOR (IAND (BLIN(BCOUNT),4ZFF00),ALIN(ACOUNT))
BCOUNT = BCOUNT + 1
WHICHS = LEFT
30 CONTINUE
ACOUNT = ACOUNT + 1
IF (ALIN(ACOUNT) .NE. LF) GO TO 10
40 CONTINUE
RETURN
END