PDP-10 Archive: tools/cbldoc1/alfjus.cob from integ_tools_tops20_v7_30-apr-86

Trailing-Edge - PDP-10 Archives - integ_tools_tops20_v7_30-apr-86_dumper - tools/cbldoc1/alfjus.cob

There are 5 other files named alfjus.cob in the archive. Click here to see a list.

IDENTIFICATION DIVISION.
PROGRAM-ID. ALFJUS.

AUTHOR. D. VISSER.
DATE-WRITTEN.  06-May-83.
DATE-COMPILED.

************************************************************************
*****
*****		PROGRAM NAME: ALFJUS
*****
*****		PURPOSE:
*****			Right justify the accepted input according to the
*****			lenght specified.
*****
*****		NOTES:
*****			VAX-11 COBOL always accepts left-justified, regardless 
*****			of the picture specified for the receiving field 
*****			( accept actually overwrites this picture). 
*****
*****			Parameters to be passed on to this subroutine and will
*****			be handed back are (in this order to be passed on) :
*****                   
*****			WK-ALFANUMERIC : 20 characters alfanumeric, containing
*****					 the input to be right-justified and
*****					 the result to hand back to the program.
*****			WK-LENGHT      : 2 digits numeric, containing the 
*****					 lenght of the input.
*****
*****                   This routine will right-justify the accepted field 
*****			'WK-ALFANUMERIC', starting the right-justification
*****			on the position spacified in 'WK-LENGHT', to make
*****			a move in the calling program possible without having
*****			to use a RIGHT JUSTIFIED clause on the receiving field
*****			of the move. The right-justified result will be handed
*****			back to the program in the same field as the input 
*****			field ('WK-ALFANUMERIC').
*****
************************************************************************
*****
*****	HISTORY				CURRENT VERSION = 001
*****
*****	VERSION	DATE	PROGRAMMER	 CHANGES			
*****
************************************************************************

ENVIRONMENT DIVISION.

DATA DIVISION.

WORKING-STORAGE SECTION.

77  WK-PROGRAM-NAME		PIC X(6)		VALUE "ALFJUS".
77  WK-VERSION			PIC 999 		VALUE 001.

77  T-A				PIC 9(2).
77  T-J				PIC 9(2).

77  WK-NEGATIVE			PIC S9			VALUE -1.

77  WK-TRANSOK			PIC X.

01  WK-ALFATABLE                PIC X(20).
01  WK-A-TAB REDEFINES WK-ALFATABLE.
	05  WK-ALF  		PIC X OCCURS 20.

01  WK-JUSTTABLE		PIC X(20).
01  WK-J-TAB REDEFINES WK-JUSTTABLE.
	05  WK-JUS 		PIC X OCCURS 20.


LINKAGE SECTION.

01  WK-ALFANUMERIC		PIC X(20).
01  WK-LENGHT			PIC 9(2).

PROCEDURE DIVISION
		   USING WK-ALFANUMERIC
			 WK-LENGHT.

A-010-MAINLINE.

	IF WK-LENGHT NOT NUMERIC
		MOVE "Lenght not numeric. " TO WK-ALFANUMERIC
		MOVE 99 TO WK-LENGHT
		GO TO Z-999-RETURN.

	IF WK-LENGHT > 20
		MOVE "Lenght greater 20.  " TO WK-ALFANUMERIC
		MOVE 99 TO WK-LENGHT
		GO TO Z-999-RETURN.

	MOVE WK-ALFANUMERIC TO WK-ALFATABLE.
	MOVE WK-LENGHT TO T-J.

	MOVE ALL SPACES TO WK-JUSTTABLE.
	MOVE SPACE TO WK-TRANSOK.

	IF WK-ALFATABLE = ALL SPACES
		GO TO Z-999-RETURN.

	PERFORM A-110-JUSTIFY THRU A-110-JUSTIFY-EX
		VARYING T-A FROM 20 BY WK-NEGATIVE
		UNTIL T-A < 1
		   OR T-J < 1.

	MOVE WK-JUSTTABLE TO WK-ALFANUMERIC.

	GO TO Z-999-RETURN.

A-110-JUSTIFY.
	IF WK-ALF (T-A) = SPACE
		IF WK-TRANSOK = SPACE
			GO TO A-110-JUSTIFY-EX.
	MOVE WK-ALF (T-A) TO WK-JUS (T-J).
	MOVE "X" TO WK-TRANSOK.
	SUBTRACT 1 FROM T-J.

A-110-JUSTIFY-EX.
	EXIT.

Z-999-RETURN.

	EXIT PROGRAM.