C+ C CCLDSP.FTN C PROGRAM TO DISPLAY CURRENT CCL COMMANDS AVAILABLE TO USERS C C INPUTS: C SY:USERCCL.CCL - User's CCL definition file C LB:[group,1]GROUPCCL.CCL;1 - Group CCL definition file C SY:[1,5]SYSCCL.CCL - System CCL definition file C C OUTPUTS: C TI: - User terminal C C MODIFICATIONS: C DATE WHO REASON C 01/24/80 M.D. Lampi Written C 04/11/80 M.D. Lampi Include references to group CCL files C 05/23/80 M.D. Lampi Fix bug with numeric optional letters C 02/19/81 M.D. Lampi Speed up disk I/O and sort the output C in column format C C- PROGRAM CCLDSP C IMPLICIT INTEGER (A-Z) BYTE GTSKBF(32),INPUT(80),SPACE,C,CC,ZERO,LCA,UCA BYTE GRPNAM(26),Z INTEGER COLUMN, GROUP BYTE TEMP(100,7,8),SPC8(8) REAL*8 REAL8(700),SPACE8 REAL*8 TNAM(3),TINPUT(10) EQUIVALENCE (TNAM, GRPNAM),(INPUT(1),TINPUT(1)) EQUIVALENCE (TEMP(1,1,1),REAL8(1)),(SPC8(1),SPACE8) DATA SPACE /' '/, COLUMN /0/, ITIME /1/ DATA ZERO /'0'/ DATA LCA /'a'/, UCA /'A'/, Z/'Z'/ DATA TNAM /'LB:[000,','1]GROUPC','CL.CCL;1'/ DATA MAXROW /100/,MAXCOL/7/,MAXLEN/8/,GRPNAM(25)/0/ DATA TEMP /5600*"40/,SPC8/8*"40/ C C FIRST DISPLAY NAME OF PROGRAM C WRITE (1,*) 'CCL Display V2.0' C C DISABLE OTS FROM PRINTING 'NO SUCH FILE' C CALL ERRSET ( 29, .TRUE., .FALSE., .TRUE., .FALSE., 15) CALL ERRSET ( 43, .TRUE., .FALSE., .FALSE., .FALSE., 15) CALL ERRSET ( 39, .TRUE., .FALSE., .TRUE., .FALSE., 15) C C NOW CHECK TO SEE IF USERCCL.CCL EXISTS C OPEN (UNIT=2,NAME='SY:USERCCL.CCL',READONLY,TYPE='OLD', 1 ERR=90) CALL ERRTST (43, IERR) IF (IERR.EQ.1) GOTO 90 C C IF WE STAY HERE THERE IS SUCH A FILE C WRITE (1,5) 5 FORMAT (' User-defined CCL commands:'/) 10 ROW =1 !Initialize row and column COLUMN =1 DO 2 I=1,700 !Initialize data area to blanks REAL8(I) =SPACE8 2 CONTINUE C C NOW READ IT & SCAN FOR COMMANDS C 15 READ (2,20,END=29,ERR=29) LENGTH,TINPUT 20 FORMAT (Q,10A8) C C WE HAVE READ A LINE--USE SUBROUTINE TO PERFORM SCAN C LENGTH = ISCAN( LENGTH, INPUT) C C SEE IF WE FOUND ONE C IF ( LENGTH .EQ. 0) GOTO 15 C C WE HAVE A LIVE ONE -- PRINT IT OUT C C CONVERT OPTIONAL CHARACTERS IN COMMAND TO LOWER-CASE C OPTSTR = INPUT(3) - INPUT (2) IF (OPTSTR.EQ.0) GOTO 27 START = INPUT(2) - ZERO DO 25 I=6+START,LENGTH+5 IF (INPUT(I) .LT. UCA .OR. INPUT(I) .GT. Z) GOTO 25 INPUT (I) = INPUT (I) - UCA + LCA 25 CONTINUE C C Now insert into temporary data area C 27 DO 28 I=1,LENGTH TEMP (ROW,COLUMN,I)=INPUT(5+I) !Transfer character at a time 28 CONTINUE COLUMN =COLUMN+1 !Point to next column IF (COLUMN .LE. MAXCOL) GOTO 15 !Check column limits COLUMN =1 ROW =ROW+1 !Increment row IF (ROW .GT. MAXROW) STOP 'Buffer overflow' GOTO 15 C C Now sort the mess C 29 COL2 =1 ROW2 =1 INPUT (1)=0 !Zap switch flag 30 ROW =ROW2 COL =COL2 ROW2 =ROW2+1 IF (ROW2 .LE. MAXROW) GOTO 32 !Past end of row? 31 ROW2 =1 COL2 =COL2+1 IF (COL2 .GT. MAXCOL) GOTO 35 !At end of list? 32 CONTINUE IF (TEMP(ROW2,COL2,1) .EQ. "40) GOTO 31 !BLANK KEYWORD? IF (COMPAR(TEMP,ROW,COL,TEMP,ROW2,COL2) .LE. 0) GOTO 30 C DO 33 I=1,MAXLEN INPUT (1)=TEMP(ROW,COL,I) !Swap entries TEMP (ROW,COL,I)=TEMP(ROW2,COL2,I) TEMP (ROW2,COL2,I)=INPUT(1) 33 CONTINUE GOTO 30 C 35 IF (INPUT(1) .NE. 0) GOTO 29 !Continue sort C C CHECK WHICH COLUMN TO PRINT IT IN C 39 DO 41 ROW=1,MAXROW IF (TEMP(ROW,1,1) .EQ. "40) GOTO 90 !STOP AFTER LAST ENTRY WRITE (1,40) ((TEMP(ROW,COLUMN,I),I=1,MAXLEN),COLUMN=1,MAXCOL) 40 FORMAT (1X,7(8A1,3X) ) 41 CONTINUE C C COMES HERE WHEN WE REACH END OF FILE FOR XXXCCL.CCL C 90 CLOSE (UNIT=2) C C NOW SEE IF WE ARE ENTIRELY DONE, DONE WITH USERCCL.CCL, C OR DONE WITH GROUPCCL.CCL C IF ( ITIME .EQ. 3) CALL EXIT IF ( ITIME .EQ. 2) WRITE (1,95) 95 FORMAT (/' System-defined CCL commands:'/) 96 FORMAT (/' Group-defined CCL commands:'/) ITIME = ITIME + 1 IF (ITIME .EQ. 3) GOTO 99 C C FIRST TIME THROUGH - OPEN UP GROUPCCL.CCL C MUST FIRST DETERMINE GROUP C CALL GETTSK (GTSKBF) !USE GETTSK TO GET TASK PARAMETERS GROUP = GTSKBF (16) !GET GROUP CODE GRPNAM (5) = (GROUP .AND. "300) / "100 + GRPNAM (5) GRPNAM (6) = (GROUP .AND. "70) / "10 + GRPNAM (6) GRPNAM (7) = (GROUP .AND. "7) + GRPNAM (7) C C NOW OPEN GROUP FILE, IF ANY C OPEN (UNIT=2,NAME=GRPNAM,READONLY,TYPE='OLD',ERR=90) WRITE (1,96) GOTO 10 !USE SAME ROUTINES C C SYSTEM CCL FILE OPENED HERE C 99 OPEN (UNIT=2,NAME='LB:[1,5]SYSCCL.CCL',READONLY,TYPE='OLD', 1 ERR=100) C C NOW USE SAME ROUTINES AS FOR USERCCL.CCL C GOTO 10 C C COMES HERE IF WE HAVE AN ERROR C 100 WRITE (1,110) 110 FORMAT (//' Unable to find LB:[1,5]SYSCCL.CCL.') GOTO 90 END FUNCTION ISCAN ( LENGTH, INPUT ) IMPLICIT INTEGER (A-Z) BYTE INPUT (80), ZERO DATA ZERO/'0'/ C C WE MUST FIRST HAVE AT LEAST 6 CHARACTERS IN 'INPUT' C ISCAN = 0 IF ( LENGTH .LT. 6) RETURN C C NEXT, WE MUST HAVE THE LETTER '$' AS THE FIRST CHARACTER C IF ( INPUT(1) .NE. '$') RETURN C C NEXT, THE 2ND & 3RD & 5TH CHARS MUST BE NUMBERS C IF ( INPUT(2) .LT. '1' .OR. INPUT(2) .GT. '9') RETURN IF ( INPUT(3) .LT. '1' .OR. INPUT(3) .GT. '9') RETURN IF ( INPUT(5) .LT. '0' .OR. INPUT(5) .GT. '9') RETURN C C FINALLY, THE 4TH CHAR MUST BE BETWEEN 0 AND : C IF ( INPUT(4) .LT. '0' .OR. INPUT(4). GT. ':') RETURN C C SET MAXIMUM LENGTH FOR SCAN C IF ( LENGTH .GT. 13) LENGTH = 13 C C NOW SEE WHERE COMMAND ACTUALLY TERMINATES (1ST SPACE) C INPLEN = INPUT (3) - ZERO DO 10, I=6,LENGTH IF ( INPUT(I) .EQ. ' ') GOTO 20 10 CONTINUE C ENTIRE COMMAND IS FILLED IN (MAX OF 8 CHARACTERS) LENGTH = LENGTH - 5 GOTO 30 C WE FOUND A SPACE AFTER COMMAND 20 LENGTH = MIN ( I - 6, INPLEN) C RETURN THE ACTUAL COMMAND LENGTH 30 LENGTH = MIN ( LENGTH, INPLEN) ISCAN = LENGTH RETURN END INTEGER FUNCTION COMPAR(INPUT,ROW,COL,OUTPUT,ROW2,COL2) IMPLICIT INTEGER (A-Z) BYTE INPUT(100,7,8), OUTPUT(100,7,8) C DO 10 I=1,8 IF (INPUT(ROW,COL,I) .LT. OUTPUT(ROW2,COL2,I)) GOTO 20 IF (INPUT(ROW,COL,I) .GT. OUTPUT(ROW2,COL2,I)) GOTO 30 10 CONTINUE COMPAR =0 !Strings equal RETURN 20 COMPAR =-1 !First string less than second RETURN 30 COMPAR =1 !First string greater than second RETURN END