C PICAX1.FOR C C---------------------------------------------------------------------- C C PICAX OVERLAY MODULE - REGION 1 C C---------------------------------------------------------------------- C LOGICAL FUNCTION INTERP() C C---------------------------------------------------------------------- C C INTERPRETS A LINE TYPED BY THE USER. THE FORM OF THE LINE C MUST BE C [LINE NUMBER] COMMAND [NUMBER[,NUMBER[,NUMBER[,NUMBER]]]] C IF A VALID LINE IS TYPED, ON RETURN INTERP IS TRUE, C OTHERWISE IT IS FALSE. C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 5 DEC 81 C C---------------------------------------------------------------------- C COMMON /P FLAGS / PROG ON, EXPT ON, QUERY COMMON /P INTER / LINE, ICMND COMMON /P C VAR / NCVAR, CVAR(1) LOGICAL PROG ON, EXPT ON, QUERY BYTE IN(2), I EQUIVALENCE (IN(1),ICMND) C C LOOK FOR LINE NUMBER C LINE = 0 ICMND = 0 INTERP = .TRUE. DO 1 II=1,NCVAR 1 CVAR(II) = 0. 10 II = NEXT(0) I = II IF (II.LT.0) RETURN IF (.NOT.NUMBER(I)) GO TO 30 LINE = LINE*10 + I IF (LINE.LE.999) GO TO 10 CALL ERROR(10) RETURN C C GET COMMAND C 30 IF (I .NE. ' ') GO TO 35 I = NEXT(0) GO TO 30 35 IN(1) = I IN(2) = ' ' II = NEXT(-1) I = II IF (II.LT.0) RETURN IF (I.LT.'A' .OR. I.GT.'Z') GO TO 40 IN(2) = I C C C SKIP REST OF WORD C 36 II = NEXT(0) II = NEXT(-1) I = II IF (I.GE.'A' .AND. I.LE.'Z') GO TO 36 C C GET VARIABLES C 40 IF (I .EQ. '?') QUERY = .TRUE. IF (QUERY) RETURN IF (II.LT.0) RETURN 45 DO 50 II=1,NCVAR IF (.NOT.NCNVRT(X)) INTERP = .FALSE. 50 CVAR(II) = X RETURN END LOGICAL FUNCTION MATCH (NCMND, NSTRNG, CSTRNG) C C---------------------------------------------------------------------- C C IF MCMND = 0, COMPARES ICMND WITH NSTRNG. C IF ICMND = NSTRNG, THEN NMATCH = NCMND, C AND MATCH = .TRUE. C IF ICMND <> NSTRNG, MATCH = .FALSE. C IF MCMND = -1, PRINTS NCMND, MSTRNG, AND CSTRNG ON CONSOLE. C IF MCMND = 1, COMPARES ICMND WITH NCMND C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 4 AUG 80 C C---------------------------------------------------------------------- C COMMON /P MATCH / MCMND, NMATCH, CHARS COMMON /P INTER / LINE, ICMND BYTE NSTRNG(1), CSTRNG(1), OUTPUT(72), MCHAR(4) EQUIVALENCE (MSTRNG,MCHAR(1)) EQUIVALENCE (CHARS ,MCHAR(1)) C MATCH = .FALSE. DO 1 I=1,4 1 MCHAR(I) = NSTRNG(I) IF (MCMND .EQ. 0) GO TO 10 IF (MCMND .EQ. 1) GO TO 20 IF (MCMND .EQ. -1) GO TO 100 RETURN 10 IF (ICMND .NE. MSTRNG) RETURN NMATCH = NCMND MATCH = .TRUE. RETURN 20 IF (ICMND .EQ. NCMND) MATCH = .TRUE. RETURN 100 IF (NCMND .EQ. 1) CALL ERASE WRITE (5,110) NCMND, MSTRNG 110 FORMAT(1X,I2'.',2X,A2' - '$) CALL PRINT (CSTRNG) RETURN END LOGICAL FUNCTION NCNVRT(X) C C---------------------------------------------------------------------- C C CONVERTS A FREE FIELD ASCII STRING INTO A NUMBER. C THE ASCII STRING IS SCANNED UNTIL AN ILLEGAL C CHARACTER, A CARRIAGE RETURN, OR A COMMA IS ENCOUNTERED. C THE NUMBER IS RETURNED IN X. IF THE STRING IS AN C INVALID NUMBER, NCNVRT IS RETURNED .FALSE. C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 4 AUG 80 C C---------------------------------------------------------------------- C BYTE ICHAR, DECFLG C NCNVRT = .TRUE. NCOMMA = 0 NDEC = 0 DECFLG = .FALSE. SIGN = 1 NESIGN = 1 X = 0. 1 ICHAR = NEXT(0) IF (ICHAR .LT. 0) RETURN IF (ICHAR .EQ. ' ') GO TO 1 IF (ICHAR .EQ. '+') GO TO 10 IF (ICHAR .NE. '-') GO TO 20 SIGN = -1. 10 ICHAR = NEXT(0) IF (ICHAR .LT. 0) GO TO 1000 20 IF (.NOT.NUMBER(ICHAR)) GO TO 50 X = X*10. + ICHAR IF (DECFLG) NDEC = NDEC+1 30 ICHAR = NEXT(0) IF (ICHAR.EQ.',' .OR. ICHAR.EQ.' ') GO TO 40 IF (ICHAR .EQ. '=') GO TO 40 IF (ICHAR .GE. 0 ) GO TO 20 40 X = SIGN*X/10.**NDEC RETURN 50 IF (ICHAR .NE. '.') GO TO 60 IF (DECFLG) GO TO 1000 DECFLG = .TRUE. GO TO 30 60 IF (ICHAR .EQ. ',') GO TO 40 IF (ICHAR .NE. 'E') GO TO 1000 ICHAR = NEXT(0) IF (ICHAR.LT.0) GO TO 1000 IF (ICHAR .EQ. '+') GO TO 70 IF (ICHAR .NE. '-') GO TO 80 NESIGN = -1 70 ICHAR = NEXT(0) IF (ICHAR .LT. 0) GO TO 1000 80 IF (.NOT.NUMBER(ICHAR)) GO TO 1000 NEXP = ICHAR ICHAR = NEXT(0) IF (ICHAR .EQ. ',') GO TO 90 IF (ICHAR .GE. 0) GO TO 100 90 X = SIGN*X/10.**(NDEC-NESIGN*NEXP) RETURN 100 IF (.NOT.NUMBER(ICHAR)) GO TO 1000 NEXP = NEXP*10 + ICHAR ICHAR = NEXT(0) IF (NEXP .LE. 20) GO TO 90 1000 NCNVRT = .FALSE. X = 0. RETURN END FUNCTION NEXT(I) C C--------------------------------------------------------------------- C C GETS THE NEXT CHARACTER FROM THE TEXT BUFFER. ON EXIT, 'NEXT' C CONTAINS THE CHARACTER AND THE TEXT BUFFER POINTER 'NPTR' IS C UPDATED BY 1+I CHARACTERS. IF NO CHARACTER IS AVAILABLE, C 'NEXT' IS SET EQUAL TO -1. C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 4 AUG 80 C C---------------------------------------------------------------------- C COMMON /P INPUT / NCHAR, STRING(72), NPTR BYTE STRING C IF (NPTR .LE. NCHAR) GO TO 10 NEXT = -1 RETURN 10 NEXT = STRING(NPTR) NPTR = NPTR+1+I RETURN END LOGICAL FUNCTION NUMBER(I) C C---------------------------------------------------------------------- C C TEST THE VALUE OF I TO SEE IF IT IS A NUMERIC CHARACTER. C ON RETURN, IF C NUMERIC : 'NUMBER' TRUE AND I=NUMERIC VALUE OF CHAR C NON-NUMERIC : 'NUMBER' FALSE AND I UNCHANGED C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 4 AUG 80 C C---------------------------------------------------------------------- C BYTE I NUMBER = .FALSE. IF (I.LT.'0' .OR. I.GT.'9') RETURN NUMBER = .TRUE. I = I-48 RETURN END SUBROUTINE SEARCH C C---------------------------------------------------------------------- C C DEFINES VALID PICAX SYSTEM COMMANDS. THE FIRST ARGUMENT C OF MATCH IS THE COMMAND NUMBER, THE SECOND ARGUMENT IS THE C ONE OR TWO LETTER COMMAND, AND THE THIRD ARGUMENT IS A C BRIEF DESCRIPTION OF THE COMMAND. C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 29 JUN 81 C C---------------------------------------------------------------------- C IF (MATCH( 1,'A ','ADD TO A USER VARIABLE')) RETURN IF (MATCH( 2,'AN','ANALYZE DATA')) RETURN IF (MATCH( 3,'CL','CLOSE THE DISK OUTPUT FILE')) RETURN IF (MATCH( 4,'DI','DIRECTORY LISTING')) RETURN IF (MATCH( 5,'DO','DO LOOP')) RETURN IF (MATCH( 6,'E ','ERASE SCREEN')) RETURN IF (MATCH( 7,'EX','EXIT PROGRAM')) RETURN IF (MATCH( 8,'FI','FIND AN OLD DISK FILE FOR INPUT')) RETURN IF (MATCH( 9,'GO','GO TO PROGRAM LINE')) RETURN IF (MATCH(10,'HE','HELP THE USER OUT')) RETURN IF (MATCH(11,'HC','MAKE HARDCOPY')) RETURN IF (MATCH(12,'K ','KILL PROGRAM')) RETURN IF (MATCH(13,'LC','LIST COMMANDS')) RETURN IF (MATCH(14,'LP','LIST PROGRAM')) RETURN IF (MATCH(15,'LV','LIST VARIABLES')) RETURN IF (MATCH(16,'O ','OPEN A NEW DISK FILE FOR OUTPUT')) RETURN IF (MATCH(17,'PL','PLOT DATA')) RETURN IF (MATCH(18,'PA','PAUSE')) RETURN IF (MATCH(19,'PR','PROCEED WITH EXPERIMENT')) RETURN IF (MATCH(20,'R ','READ A RECORD FROM DISK')) RETURN IF (MATCH(21,'S ','START EXPERIMENT')) RETURN IF (MATCH(22,'T ','ENTER TITLE')) RETURN IF (MATCH(23,'V ','SET A USER VARIABLE')) RETURN IF (MATCH(24,'W ','WRITE A RECORD TO DISK')) RETURN IF (MATCH(25,'WA','WAIT IN UNITS OF 10MS')) RETURN IF (MATCH(26,'Z ','ZERO OR INIT DATA')) RETURN CALL UMATCH RETURN END FUNCTION LINE NM (LINE) C C---------------------------------------------------------------------- C C RETURN THE LINE COUNT FOR A LINE NUMBER 'LINE'. IF THE C LINE DOES NOT EXIST, LINE NM IS RETURNED ZERO. C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - APPLIED SCIENCE C LAST MODIFICATION ON 4 AUG 80 C C---------------------------------------------------------------------- C COMMON /PROGRM / NLINES, N LN MAX, PROG(1) EQUIVALENCE (PACK,N) C LINE NM = 0 IF (NLINES .NE. 0) GO TO 30 10 CALL ERROR(11) RETURN 30 DO 40 I=1,NLINES PACK = PROG(I*5-4) IF (N .EQ. LINE) GO TO 50 40 CONTINUE GO TO 10 50 LINE NM = I RETURN END