FREQ: PROC OPTIONS(MAIN); /* Interactive/batch frequency utility version 1.0 Author: Al Jaworski Date: 29-Jan-82 Program stores counts down a set of unbalanced binary trees. Command file contains field count, columns, lengths and labels. */ % REPLACE MAX_TABLES BY 100; % REPLACE MAX_REC_SIZE BY 20000; % REPLACE TRUE BY '1'B; % REPLACE FALSE BY '0'B; %INCLUDE $STSDEF; %INCLUDE PLI_FILE_DISPLAY; %INCLUDE SYS$TRNLOG; DCL LIB$GET_FOREIGN ENTRY(CHAR(*),CHAR(*),FIXED BIN(15)) RETURNS(FIXED BIN(31)) OPTIONS(VARIABLE); DCL IN FILE INPUT RECORD; DCL LOG FILE OUTPUT STREAM; DCL CMD FILE RECORD; /* POINTERS FOR PLI_FILE_DISPLAY */ DCL (INPTR,LOGPTR,CMDPTR) POINTER; DCL IN_AREA CHAR(MAX_REC_SIZE) VARYING; DCL STORE_VALUE CHAR(40) VARYING; DCL FOREIGN_AREA CHAR(80); DCL COMMAND_AREA CHAR(80) VARYING; /* 12 X'S IS FLAG FOR BAD FILE NAME */ DCL (IN_FILE_NAME,LOG_FILE_NAME,CMD_FILE_NAME) CHAR(40) INIT('XXXXXXXXXXXX'); /* FIELD LOCATORS AND HEADERS FOR BINARY STORAGE TREES */ DCL START_COL(MAX_TABLES) FIXED BINARY(31); DCL FIELD_LENGTH(MAX_TABLES) FIXED BINARY(31); DCL END_COL(MAX_TABLES) FIXED BINARY(31); DCL FIELD_LABEL(MAX_TABLES) CHAR(80) VARYING; DCL TREE_HEADER(MAX_TABLES) POINTER; /* PROTOTYPE NODE FOR COUNTER BINARY TREE */ DCL 1 NODE BASED, 2 LEFT POINTER, 2 RIGHT POINTER, 2 COUNT FIXED BINARY(31), 2 VALUE CHAR(FIELD_LENGTH(I)); DCL (EOF_FLAG,BAD_DATA_FLAG,RECORD_TRUNCATE_FLAG,BATCH_FLAG) BIT(1); DCL (I,REC_COUNT,CUM_COUNT,NUM_FIELDS) FIXED BINARY(31) INIT(0); DCL (COMMAND_LENGTH,TERMINAL_LENGTH) FIXED BINARY(15) INIT(0); DCL TERMINAL CHAR(63) INIT(' '); ON UNDEFINEDFILE(IN) BEGIN; PUT EDIT('Data file cannot be opened--',IN_FILE_NAME)(SKIP,2 A); IF BATCH_FLAG THEN STOP; IN_FILE_NAME='XXXXXXXXXXXX'; END; ON UNDEFINEDFILE(LOG) BEGIN; PUT EDIT('Report file cannot be opened--',LOG_FILE_NAME)(SKIP,2 A); IF BATCH_FLAG THEN STOP; LOG_FILE_NAME='XXXXXXXXXXXX'; END; ON UNDEFINEDFILE(CMD) BEGIN; PUT EDIT('Command file cannot be opened--',CMD_FILE_NAME)(SKIP,2 A); IF BATCH_FLAG THEN STOP; CMD_FILE_NAME='XXXXXXXXXXXX'; END; PUT EDIT('Westat Frequency Utility--Version 1.1--',DATE()) (SKIP(2),A,P'99/99/99'); /* DETERMINE WHETHER PROGRAM IS RUNNING BATCH OR INTERACTIVE AND GET FILE NAMES */ STS$VALUE = SYS$TRNLOG('TT',TERMINAL_LENGTH,TERMINAL,,,,); IF STS$SUCCESS THEN DO; IF INDEX(TERMINAL,':')=0 THEN DO; BATCH_FLAG=TRUE; PUT EDIT('--Batch mode')(A); END; ELSE DO; BATCH_FLAG=FALSE; PUT EDIT('--Interactive mode')(A); END; END; ELSE PUT EDIT('Unable to determine whether running batch or interactive') (SKIP,A); STS$VALUE=LIB$GET_FOREIGN(FOREIGN_AREA,,COMMAND_LENGTH); IF STS$SUCCESS THEN DO; IF FOREIGN_AREA^=' ' THEN DO; IN_FILE_NAME=LOP(FOREIGN_AREA); OPEN FILE(IN) TITLE(IN_FILE_NAME); END; IF FOREIGN_AREA^=' ' THEN DO; CMD_FILE_NAME=LOP(FOREIGN_AREA); OPEN FILE(CMD) INPUT TITLE(CMD_FILE_NAME); END; IF FOREIGN_AREA^=' ' THEN DO; LOG_FILE_NAME=LOP(FOREIGN_AREA); OPEN FILE(LOG) TITLE(LOG_FILE_NAME); ALLOC PLI_FILE_DISPLAY SET(LOGPTR); CALL DISPLAY(LOG,LOGPTR->PLI_FILE_DISPLAY); END; END; ELSE DO; PUT EDIT('File parameters are in error')(SKIP(2),A); STOP; END; /* GET DATA FILE NAME AND DISPLAY CHARACTERISTICS */ ALLOCATE PLI_FILE_DISPLAY SET (INPTR); DO WHILE(IN_FILE_NAME='XXXXXXXXXXXX'); PUT SKIP(2); GET EDIT(IN_FILE_NAME)(A(40)) OPTIONS(PROMPT('Input Data File Name?: ')); OPEN FILE(IN) TITLE(IN_FILE_NAME); END; CALL DISPLAY(IN,INPTR->PLI_FILE_DISPLAY); PUT EDIT ('Input Data File Name is ',INPTR->EXPANDED_TITLE) (SKIP(2),2 A); IF INPTR->MAXIMUM_RECORD_SIZE>0 THEN PUT EDIT('Maximum Record Size is ',INPTR->MAXIMUM_RECORD_SIZE) (SKIP,A,P'ZZZZ9'); IF INPTR->FIXED_LENGTH_RECORDS THEN PUT EDIT('Record Type is fixed length')(SKIP,A); ELSE PUT EDIT('Record Type is variable length')(SKIP,A); /* GET REPORT FILE NAME */ DO WHILE(LOG_FILE_NAME='XXXXXXXXXXXX'); PUT SKIP(2); GET EDIT(LOG_FILE_NAME)(A(40)) OPTIONS(PROMPT('Report File Name? ( for terminal output): ')); IF LOG_FILE_NAME=' ' THEN OPEN FILE(LOG) TITLE('TT'); ELSE OPEN FILE(LOG) TITLE(LOG_FILE_NAME); END; IF LOG_FILE_NAME^=' ' THEN DO; ALLOC PLI_FILE_DISPLAY SET(LOGPTR); CALL DISPLAY(LOG,LOGPTR->PLI_FILE_DISPLAY); PUT FILE(LOG) EDIT ('Input Data File Name is ',INPTR->EXPANDED_TITLE) (SKIP(2),2 A); IF INPTR->MAXIMUM_RECORD_SIZE>0 THEN PUT FILE(LOG) EDIT('Maximum Record Size is ',INPTR->MAXIMUM_RECORD_SIZE) (SKIP,A,P'ZZZZ9'); IF INPTR->FIXED_LENGTH_RECORDS THEN PUT FILE(LOG) EDIT('Record Type is fixed length')(SKIP,A); ELSE PUT FILE(LOG) EDIT('Record Type is variable length')(SKIP,A); END; /* GET COMMAND FILE NAME */ DO WHILE(CMD_FILE_NAME='XXXXXXXXXXXX'); PUT SKIP(2); GET EDIT(CMD_FILE_NAME)(A(40)) OPTIONS(PROMPT('Command File Name? ( to create): ')); IF CMD_FILE_NAME^=' ' THEN OPEN FILE(CMD) INPUT TITLE(CMD_FILE_NAME); END; IF CMD_FILE_NAME=' ' THEN DO; PUT EDIT('Enter fields to be counted', 'Exit with in response to ''Field Label?'' prompt') (SKIP(2),A,SKIP,A); EOF_FLAG=FALSE; PUT SKIP(2); DO I=1 TO MAX_TABLES WHILE(EOF_FLAG=FALSE); GET EDIT(FIELD_LABEL(I))(A(80)) OPTIONS(PROMPT('Field Label?: ')); IF FIELD_LABEL(I)=' ' THEN EOF_FLAG=TRUE; ELSE DO; CALL GET_NUMBER(START_COL(I),'Field Start Column?: ',1,MAX_REC_SIZE); CALL GET_NUMBER(FIELD_LENGTH(I),'Field Length?: ',1,40); NUM_FIELDS=NUM_FIELDS+1; END_COL(I)=START_COL(I)+FIELD_LENGTH(I)-1; IF (INPTR->MAXIMUM_RECORD_SIZE>0) & (END_COL(I)>INPTR->MAXIMUM_RECORD_SIZE) THEN DO; PUT EDIT(FIELD_LABEL(I), 'End column exceeds maximum record size') (SKIP(2),A,SKIP,A); STOP; END; END; PUT SKIP; END; IF NUM_FIELDS>0 THEN DO; PUT EDIT('Number of fields defined is ',NUM_FIELDS)(SKIP(2),A,P'ZZ9'); CMD_FILE_NAME='XXXXXXXXXXXX'; DO WHILE(CMD_FILE_NAME='XXXXXXXXXXXX'); PUT SKIP(2); GET EDIT(CMD_FILE_NAME)(A(40)) OPTIONS(PROMPT('Command File Name? : ')); OPEN FILE(CMD) OUTPUT TITLE(CMD_FILE_NAME); END; PUT STRING(COMMAND_AREA) EDIT(NUM_FIELDS)(F(3)); WRITE FILE(CMD) FROM (COMMAND_AREA); DO I=1 TO NUM_FIELDS; PUT STRING(COMMAND_AREA) EDIT(START_COL(I),END_COL(I),FIELD_LENGTH(I)) (F(6),F(6),F(3),A); WRITE FILE(CMD) FROM (COMMAND_AREA); WRITE FILE(CMD) FROM (FIELD_LABEL(I)); END; END; ELSE DO; PUT EDIT('No fields defined--Frequencies terminated') (SKIP(2),A); STOP; END; END; ELSE DO; ON ERROR BEGIN; PUT EDIT('Bad data in command file--Program terminated')(SKIP,A); STOP; END; READ FILE(CMD) INTO(COMMAND_AREA); GET STRING(COMMAND_AREA) LIST(NUM_FIELDS); DO I=1 TO NUM_FIELDS; READ FILE(CMD) INTO(COMMAND_AREA); GET STRING(COMMAND_AREA) LIST(START_COL(I),END_COL(I),FIELD_LENGTH(I)); READ FILE(CMD) INTO(FIELD_LABEL(I)); END; END; ALLOC PLI_FILE_DISPLAY SET(CMDPTR); CALL DISPLAY(CMD,CMDPTR->PLI_FILE_DISPLAY); PUT EDIT ('Command File Name is ',CMDPTR->EXPANDED_TITLE) (SKIP(2),2 A); TREE_HEADER=NULL(); REC_COUNT=0; ON ENDFILE(IN) EOF_FLAG=TRUE; EOF_FLAG=FALSE; RECORD_TRUNCATE_FLAG=FALSE; /* PERFORMS COUNTS BY SEARCHING BINARY TREES */ READ FILE(IN) INTO (IN_AREA); DO WHILE(EOF_FLAG=FALSE); DO I=1 TO NUM_FIELDS; IF END_COL(I)>LENGTH(IN_AREA) THEN DO; STORE_VALUE=COPY('#',FIELD_LENGTH(I)); RECORD_TRUNCATE_FLAG=TRUE; END; ELSE STORE_VALUE=SUBSTR(IN_AREA,START_COL(I),FIELD_LENGTH(I)); CALL TREE_STORE(TREE_HEADER(I)); END; REC_COUNT=REC_COUNT+1; READ FILE(IN) INTO (IN_AREA); END; /* WRITE FREQUENCY TABLES */ PUT FILE(LOG) EDIT('Data file record count is ',REC_COUNT)(SKIP,A,P'ZZZZZ9'); IF RECORD_TRUNCATE_FLAG THEN PUT FILE(LOG) EDIT ('Warning--Some fields ran past ends of records--flagged with #''s') (SKIP,A); DO I=1 TO NUM_FIELDS; PUT FILE(LOG) EDIT('Frequency--',FIELD_LABEL(I), '') (SKIP(4),A,A,SKIP,A); PUT SKIP; CUM_COUNT=0; CALL TREE_DUMP(TREE_HEADER(I)); END; IF LOG_FILE_NAME^=' ' THEN PUT EDIT ('Report is stored in file ',LOGPTR->EXPANDED_TITLE) (SKIP,2 A); /* END OF MAIN PROGRAM BODY */ TREE_STORE: PROC(P); DCL P POINTER; IF P=NULL() THEN DO; ALLOCATE NODE SET(P); P->LEFT=NULL(); P->RIGHT=NULL(); P->VALUE=STORE_VALUE; P->COUNT=1; END; ELSE IF STORE_VALUE=P->VALUE THEN P->COUNT=P->COUNT+1; ELSE IF STORE_VALUEVALUE THEN CALL TREE_STORE(P->LEFT); ELSE IF STORE_VALUE>P->VALUE THEN CALL TREE_STORE(P->RIGHT); END TREE_STORE; TREE_DUMP: PROC(P); DCL P POINTER; IF P=NULL() THEN RETURN; CALL TREE_DUMP(P->LEFT); CUM_COUNT=CUM_COUNT+(P->COUNT); PUT FILE(LOG) EDIT (P->VALUE,P->COUNT,(FLOAT(P->COUNT*100,24)/REC_COUNT),' % ', CUM_COUNT,(FLOAT(CUM_COUNT*100,24)/REC_COUNT),' % ') (SKIP,A,X(2),F(6),X(2),F(6,2),A,F(6),X(2),F(6,2),A); CALL TREE_DUMP(P->RIGHT); END TREE_DUMP; GET_NUMBER: PROC(VALUE,PROMPT_STRING,RANGE1,RANGE2); /* ROUTINE PROMPTS FOR A NUMBER CHECKING RANGE AND OTHER ERROR CONDITIONS */ DCL (VALUE,RANGE1,RANGE2) FIXED BINARY(31); DCL PROMPT_STRING CHAR(*); DCL ANSWER CHAR(10); DCL ERROR_FLAG BIT(1); ON ERROR ERROR_FLAG=TRUE; ENTER: ERROR_FLAG=FALSE; GET EDIT(ANSWER)(A(10)) OPTIONS(PROMPT(PROMPT_STRING)); VALUE=FIXED(ANSWER,31); IF VALUERANGE2 | ERROR_FLAG THEN DO; PUT EDIT('Invalid answer--Must be numeric between ', RANGE1,' and ',RANGE2) (SKIP(2),A,F(5),A,F(5)); PUT SKIP; GO TO ENTER; END; END GET_NUMBER; LOP: PROC(R) RETURNS(CHAR(80)); DCL (R,T) CHAR(80); DO WHILE(SUBSTR(R,1,1)=' '); R=SUBSTR(R,2); END; I=INDEX(R,' '); IF I=0 | I=80 THEN DO; T=R; R=''; END; ELSE DO; T=SUBSTR(R,1,I); R=SUBSTR(R,I+1); END; RETURN(T); END LOP; END FREQ;