IDENTIFICATION  DIVISION.
PROGRAM-ID. LIBPROG.
AUTHOR. KG.
*
*    **********************************************************
*    **                                                      **
*    **     REFERENCES CROISEES COPY-LIB/PROGRAMMES          **
*    **                                                      **
*    **********************************************************
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. VAX-11.
OBJECT-COMPUTER. VAX-11.
SPECIAL-NAMES.
	SYMBOLIC CHARACTERS TABULA ARE 10
	DECIMAL-POINT IS COMMA.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*
*
      SELECT  PARAM   ASSIGN TO "DIR.LST".
      SELECT  ENTRE   ASSIGN TO "".
      SELECT  SORTIE     ASSIGN TO "LPCREF.DAT".
*
*
*****************************************************************
*                        DATA DIVISION
*****************************************************************
*
 DATA DIVISION.
*
 FILE SECTION.
*
FD	PARAM
	LABEL RECORD STANDARD.
*
01	DIRENR.
	02 DI-C		PIC X OCCURS 80.
*
FD	ENTRE
	VALUE OF ID IS FICHENTR
	LABEL RECORD STANDARD RECORD VARYING 
	FROM 1 TO 255 DEPENDING ON ILE.
01	ENRENTR.
	02 CE		PIC X OCCURS 255.
01	ER0.
	02 FILLER		PIC X.
	02 ER1.
	  03 FILLER		PIC X.
	  03 ER2.
	    04 FILLER		PIC X.
	    04 ER3.
	      05 FILLER		PIC X.
	      05 ER4.
	        06 FILLER	PIC X.
	        06 ER5		PIC X(248).
01	ENRENTV.
	02 ZE1.
	  03 ZE3.
	    04 ZE2		PIC X(5).
	    04 FILLER		PIC X(5).
	  03 FILLER		PIC XX.
*
FD	SORTIE
	LABEL RECORD IS STANDARD.
	COPY LPCREF.
*
WORKING-STORAGE SECTION.
*
77	SAV-DIV		PIC X.
77	ILE		PIC 9999 COMP.
77	LLE		PIC S9999 COMP.
77	IX              PIC S999 COMP.
77	K               PIC S999 COMP.
77	NUMD            PIC S99 COMP.
77	TALL            PIC S999 COMP.
77	LRF             PIC X.
77	C               PIC X.
77	CP              PIC X.
77	AIGD            PIC 9.
77	TAB             PIC X.
77	L1		PIC S999 COMP.
77	L2		PIC S999 COMP.
01	IK		PIC 9(9) COMP.
01	XCOP		PIC X(4) VALUE "COPY".
*
01	FICHENTR.
	02 CNF          PIC X(40).
01	NOM.
	02 CNN		PIC X OCCURS 9.
*
01	AIG1            PIC X.
*
01	TABW.
	02 CW           PIC X OCCURS 32.
*
/
PROCEDURE DIVISION.
BEG_PGM SECTION.
BEG.
	MOVE TABULA TO TAB.
	OPEN INPUT PARAM.
	OPEN OUTPUT SORTIE.
LP.
	MOVE SPACE TO DIRENR.
	READ PARAM AT END GO TO FIN.
	MOVE DIRENR TO FICHENTR.
*			RECHERCHE NOM DU PROGRAMME
	MOVE SPACE TO NOM.
	MOVE 1 TO L1.
	MOVE ZERO TO L2.
LNNA.
	IF DI-C (L1) = "]" GO TO AP-LNNA.
	IF L1 < 80 ADD 1 TO L1 GO TO LNNA.
	DISPLAY "DESCRIPTION NON CONFORME " DIRENR.
	GO TO LP.
AP-LNNA.
	ADD 1 TO L1.
	ADD 1 TO L2.
	IF L1 > 80 GO TO AP-NN.
	IF L2 > 9 GO TO AP-NN.
	IF DI-C (L1) = "." GO TO AP-NN.
	MOVE DI-C (L1) TO CNN (L2).
	GO TO AP-LNNA.
AP-NN.
*			TRAITEMENT PROGRAMME
	OPEN INPUT ENTRE.
	MOVE ZERO TO AIGD.
	MOVE SPACE TO AUS.
	MOVE NOM TO AU-PROG.
LECT.
	MOVE SPACE TO ENRENTR.
	READ ENTRE AT END GO TO FERM.
	MOVE ILE TO LLE.
	IF LLE = ZERO GO TO LECT.
	IF ENRENTR = SPACE GO TO LECT.
	MOVE ZERO TO TALL.
	INSPECT ENRENTR TALLYING TALL FOR LEADING SPACE
				TALL FOR LEADING TAB.
	IF TALL = ZERO GO TO AP-CADRAGE.
	IF TALL = 1 MOVE ER1 TO ER0 GO TO AP-CADRAGE.
	IF TALL = 2 MOVE ER2 TO ER0 GO TO AP-CADRAGE.
	IF TALL = 3 MOVE ER3 TO ER0 GO TO AP-CADRAGE.
	IF TALL = 4 MOVE ER4 TO ER0 GO TO AP-CADRAGE.
	IF TALL = 5 MOVE ER5 TO ER0 GO TO AP-CADRAGE.
	MOVE 1 TO IX.
	ADD 1 TALL GIVING K.
CADRAGE.
	MOVE CE (K) TO CE (IX).
	MOVE SPACE TO CE (K).
	IF K < LLE ADD 1 TO K ADD 1 TO IX GO TO CADRAGE.
AP-CADRAGE.
	MOVE ZERO TO IX.
	IF AIGD NOT = ZERO GO TO AP-ENVIR.
	IF ZE1 NOT = "ENVIRONMENT " GO TO LECT.
	MOVE 1 TO AIGD.
	MOVE "E" TO AU-DIV.
	GO TO LECT.
*			RECHERCHE DES COPY
AP-ENVIR.
	IF ZE2 = "DATA " MOVE "D" TO AU-DIV GO TO LECT.
	IF ZE3 = "PROCEDURE " MOVE "P" TO AU-DIV GO TO LECT.
	CALL "LIB$INDEX" USING	BY DESCRIPTOR ENRENTR
				BY DESCRIPTOR XCOP
		GIVING IK.
	IF IK = ZERO GO TO LECT.
	IF IK = 1 SUBTRACT 1 FROM IK GIVING IX
		MOVE SPACE TO CP.
	IF IK > 1 SUBTRACT 2 FROM IK GIVING IX
		MOVE "@" TO CP.
LOOP.
	ADD 1 TO IX.
	IF IX > LLE GO TO LECT.
	MOVE CE (IX) TO C.
	IF C = "C" AND CP = SPACE GO TO COPRO.
	MOVE C TO CP.
	GO TO LOOP.
COPRO.
	PERFORM DEMOT.
*			TEST SI TABW = COPY
AP-DEMOT.
	IF TABW NOT = "COPY" MOVE SPACE TO CP
		GO TO LOOP.
*			RECHERCHE PROCHAIN MOT
ENTMOT.
	ADD 1 TO IX.
	IF IX > LLE GO TO AP-ENTMOT.
	MOVE CE (IX) TO C.
	IF C = SPACE OR TAB GO TO ENTMOT.
AP-ENTMOT.
	IF IX > LLE MOVE "??" TO TABW
		ELSE PERFORM DEMOT.
	MOVE TABW TO AU-LIB.
*		ECRITURE SORTIE
WR.
	IF CE (1) = "*" MOVE AU-DIV TO SAV-DIV
		MOVE "*" TO AU-DIV.
	WRITE AUS.
	IF CE (1) = "*" MOVE SAV-DIV TO AU-DIV.
AP-WR.
	GO TO LECT.
*
************************************************************
*		FIN D'UN PROGRAMME COBOL
************************************************************
*
FERM_FICH SECTION.
FERM.
	CLOSE ENTRE.
	GO TO LP.
*
**********************************************************
*	TRANSFERT UN MOT COBOL DANS TABW
**********************************************************
*
DEMOT SECTION.
DEMOT_00.
	MOVE SPACE TO TABW.
	MOVE 1 TO K.
DEMOT_10.
	MOVE CE (IX) TO CW (K).
	ADD 1 TO K.
	ADD 1 TO IX.
	IF K > 32 OR IX > LLE GO TO ODEMOT.
	MOVE CE (IX) TO C.
	IF C = SPACE OR "." OR "(" GO TO ODEMOT.
	GO TO DEMOT_10.
ODEMOT.
	EXIT.
*
**********************************************************
*		FIN DU FICHIER PARAMETRE
**********************************************************
*
FIN_PGM SECTION.
FIN.
	CLOSE PARAM SORTIE.
	STOP RUN.
