C PICAXR.FOR C PROGRAM PICAX C C---------------------------------------------------------------------- C C P I C A X - PROGRAM FOR INTERACTIVE CONTROL AND C ACQUISITION FOR EXPERIMENTS C C---------------------------------------------------------------------- C C ROOT MODULE C C---------------------------------------------------------------------- C C PICAX IS A SET OF ROUTINES DESIGNED TO PROVIDE THE USER WITH C MANY OF THE OPERATIONS REQUIRED IN A GENERAL LABORATORY DATA C ACQUISITION AND ANALYSIS ENVIRONMENT. PICAX PROVIDES A C HIGH-LEVEL INTERACTIVE COMMAND LANGUAGE WHICH CALLS C USER-WRITTEN SUBROUTINES WHICH IN TURN CALL ROUTINES IN C THE PICAX LIBRARY. FOR MORE INFORMATION SEE THE PICAX C USER'S GUIDE. C C WRITTEN BY ROBERT WALRAVEN C DEPARTMENT OF APPLIED SCIENCE C UNIVERSITY OF CALIFORNIA, DAVIS C LAST MODIFICATION ON 5 DEC 81 C C---------------------------------------------------------------------- C COMMON /P FLAGS/ PROG ON, EXPT ON, QUERY LOGICAL PROG ON, EXPT ON, QUERY COMMON /P INTER/ LINE, ICMND COMMON /P MATCH/ MCMND, NMATCH, CHARS C CALL BINITT !INITIALIZE GRAPHICS CALL ERASE !ERASE SCREEN CALL INIT !INITIALIZE PICAX C 10 WRITE (5,20) 20 FORMAT(1X,'*'$) 30 IF ( INPUT(NUM CHR) ) GO TO 50 40 IF (EXPT ON) CALL UPDATE IF (.NOT. PROG ON) GO TO 30 CALL XECUTE(NMATCH) CALL NXT LN IF (PROG ON) GO TO 30 GO TO 10 50 EXPT ON = .FALSE. PROG ON = .FALSE. IF (NUM CHR .EQ. 0) GO TO 10 IF (NUM CHR .NE. -1) GO TO 60 CALL ERROR(1) GO TO 10 60 IF (INTERP()) GO TO 70 CALL ERROR(3) GO TO 10 70 IF (LINE.EQ.0 .OR. ICMND.NE.0) GO TO 80 CALL DELETE GO TO 10 80 NMATCH = 0 CALL SEARCH IF (NMATCH .EQ. 0) GO TO 90 NUM ERR = 0 IF (LINE .EQ. 0) CALL XECUTE(NMATCH) IF (LINE .NE. 0) CALL INSERT GO TO 10 90 NUM ERR = NUM ERR + 1 IF (NUM ERR .EQ. 3) GO TO 100 CALL ERROR(2) GO TO 10 100 NUM ERR = 0 CALL XECUTE (13) GO TO 10 END SUBROUTINE XECUTE (N) C C---------------------------------------------------------------------- C C EXECUTES SYSTEM COMMANDS C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - DAVIS C LAST MODIFICATION ON 19 SEP 81 C C---------------------------------------------------------------------- C COMMON /P C VAR / NCVAR, CVAR(1) COMMON /P DO VAR / DO FRST, DO LAST, DO CNT COMMON /P FILES / NOPEN, LUNOPN(6), LUNFND(6), NFOUND COMMON /P FLAGS / PROG ON, EXPT ON, QUERY COMMON /P INTER / LINE, ICMND COMMON /P MATCH / MCMND, NMATCH, CHARS COMMON /PROGRM / NLINES, N LN MAX, PROG(1) COMMON /P VAR / NCTRLC, LN PTR, P VERSN COMMON /P TITLE / LTITLE (36) COMMON /U VAR / NUVAR, UVAR(1) LOGICAL PROG ON, EXPT ON, QUERY INTEGER DO FRST, DO LAST, DO CNT C IF (.NOT.QUERY) GO TO 10 CALL INFO(N) QUERY = .FALSE. RETURN 10 GO TO (100,200,300,400,500,600,700,800,900,1000,1100,1200,1300, 1 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400,2500, 2 2600,2700,2800),N C C----------------------------------------ADD TO A GENERAL VARIABLE 100 I = CVAR(1) IF (I.GE.1 .AND. I.LE.NUVAR) GO TO 130 CALL ERROR(4) RETURN 130 UVAR(I) = UVAR(I) +CVAR(2) RETURN C----------------------------------------ANALYZE DATA 200 CALL UANLYZ RETURN C----------------------------------------CLOSE THE DISK OUTPUT FILE 300 LUN = 2 IF (CVAR(1) .NE. 0.) LUN = CVAR(1) IF (NOPEN .NE. 0) GO TO 305 CALL ERROR (16) 305 DO 310 I=1,NOPEN IF (LUN .EQ. LUNOPN(I)) GO TO 320 310 CONTINUE CALL ERROR (17) RETURN 320 CALL CLOSE(LUN) IF (I .EQ. NOPEN) LUNOPN (NOPEN) = 0 LUNOPN(I) = LUNOPN(NOPEN) NOPEN = NOPEN - 1 RETURN C----------------------------------------DIRECTORY LISTING 400 I = CVAR(1) IF (I.NE.6) I=5 CALL ERASE CALL DIREC (I,'DK:') RETURN C----------------------------------------DO LOOP 500 I = CVAR(1) DO LAST = LINE NM (I) IF (DO LAST .NE. 0) GO TO 520 CALL ERROR(5) RETURN 520 DO CNT = CVAR(2) DO FRST = LN PTR RETURN C----------------------------------------ERASE SCREEN 600 CALL ERASE RETURN C----------------------------------------EXIT 700 IF (NOPEN .EQ. 0) GOTO 720 DO 710, I=1,NOPEN 710 CALL CLOSE(LUNOPN(I)) 720 CALL SCCA CALL EXIT C----------------------------------------FIND OLD DISK INPUT FILE 800 LUN = 3 IF (CVAR(1) .NE. 0.) LUN = CVAR(1) IF (NFOUND .EQ. 0) GOTO 830 DO 810, I=1, NFOUND IF (LUN .EQ. LUNFND(I)) GO TO 820 810 CONTINUE GO TO 830 820 CALL CLOSE(LUN) IF (I .EQ. NFOUND) LUNFND(NFOUND) = 0 LUNFND(I) = LUNFND(NFOUND) NFOUND = NFOUND - 1 830 IF (NFOUND .EQ. 6) GO TO 840 IF (IOFILE(LUN,'OLD',0,0).GE.0) GO TO 850 840 CALL ERROR(6) RETURN 850 NFOUND = NFOUND + 1 LUNFND(NFOUND) = LUN CALL UREAD(-LUN) RETURN C----------------------------------------GO 900 I = CVAR(1) IF (I .EQ. 0) GO TO 910 LN PTR = LINE NM(I) IF (LN PTR .NE. 0) GO TO 920 CALL ERROR(7) RETURN 910 LN PTR = 1 920 PROG ON = .TRUE. RETURN C----------------------------------------HELP 1000 CALL ERROR(8) RETURN C----------------------------------------HARD COPY 1100 CALL HDCOPY RETURN C----------------------------------------KILL PROGRAM 1200 NLINES = 0 PROG ON = .FALSE. RETURN C----------------------------------------LIST COMMANDS 1300 MCMND = -1 CALL SEARCH MCMND = 0 RETURN C----------------------------------------LIST PROGRAM 1400 CALL PLIST RETURN C----------------------------------------LIST VARIABLES 1500 CALL UVLIST RETURN C----------------------------------------OPEN NEW DISK OUTPUT FILE 1600 IF (NOPEN .EQ. 6) GOTO 1610 ISIZE = CVAR(2) LUN = 2 IF (CVAR(1) .NE. 0) LUN = CVAR(1) IF (NOPEN .EQ. 0) GO TO 1608 DO 1602 I=1,NOPEN IF (LUN .EQ. LUNOPN(I)) GO TO 1604 1602 CONTINUE GO TO 1608 1604 CALL CLOSE(LUN) IF (I.EQ.NOPEN) LUNOPN(NOPEN)=0 LUNOPN(I) = LUNOPN(NOPEN) NOPEN=NOPEN-1 1608 IF (IOFILE(LUN,'NEW',0,ISIZE).GE.0) GO TO 1620 1610 CALL ERROR(9) RETURN 1620 NOPEN = NOPEN + 1 LUNOPN(NOPEN) = LUN CALL UWRITE (-LUN) RETURN C----------------------------------------PLOT DATA 1700 CALL UPLOT RETURN C----------------------------------------PAUSE 1800 IF (ITTINR().NE."12) GO TO 1800 RETURN C----------------------------------------PROCEED 1900 EXPT ON = .TRUE. CALL UPROCD RETURN C----------------------------------------READ 2000 LUN = 3 IF (CVAR(1) .NE. 0) LUN = CVAR(1) IF (NFOUND .EQ. 0) GO TO 2020 DO 2010, I=1,NFOUND IF (LUN .EQ. LUNFND(I)) GO TO 2030 2010 CONTINUE 2020 CALL ERROR(15) RETURN 2030 CALL UREAD(LUN) RETURN C----------------------------------------START 2100 EXPT ON = .TRUE. CALL USTART RETURN C----------------------------------------TITLE 2200 CALL TITLE RETURN C----------------------------------------SET A VARIABLE 2300 I = CVAR(1) IF (I.GE.1 .AND. I.LE.NUVAR) GO TO 2310 CALL ERROR(4) RETURN 2310 UVAR(I) = CVAR(2) RETURN C----------------------------------------WRITE 2400 LUN = 2 IF (CVAR(1) .NE. 0) LUN = CVAR(1) IF (NOPEN .EQ. 0) GO TO 2420 DO 2410, I=1,NOPEN IF (LUN .EQ. LUNOPN(I)) GO TO 2430 2410 CONTINUE 2420 CALL ERROR(13) RETURN 2430 CALL UWRITE(LUN) RETURN C----------------------------------------WAIT 2500 I = CVAR(1) CALL IOWAIT (I) RETURN C----------------------------------------ZERO 2600 CALL UZERO RETURN C-----------------------------------USER COMMANDS 2700 CALL UCMNDS (N) RETURN C 2800 RETURN C END SUBROUTINE NXT LN C C---------------------------------------------------------------------- C C GETS NEXT LINE OF PROGRAM C C THIS ROUTINE IS PART OF THE PICAX PROGRAM C WRITTEN BY ROBERT WALRAVEN, UCD - DAVIS C LAST MODIFICATION ON 29 JUN 81 C C---------------------------------------------------------------------- C COMMON /P C VAR / NCVAR, CVAR(1) COMMON /P DO VAR / DO FRST, DO LAST, DO CNT COMMON /P FLAGS / PROG ON, EXPT ON, QUERY COMMON /P MATCH / MCMND, NMATCH, CHARS COMMON /PROGRM / NLINES, N LN MAX, PROG(1) COMMON /P VAR / NCTRLC, LN PTR, P VERSN LOGICAL PROG ON, EXPT ON, QUERY INTEGER DO FRST, DO LAST, DO CNT DIMENSION N(2) EQUIVALENCE (PACK,N(1)) C IF (.NOT. PROG ON) RETURN IF (DO CNT .EQ. 0) GO TO 10 IF (LN PTR .LE. DO LAST) GO TO 10 DO CNT = DO CNT - 1 IF (DO CNT .NE. 0) LN PTR = DO FRST 10 IF (LN PTR .LT. NLINES+1) GO TO 20 PROG ON = .FALSE. RETURN 20 INDEX = LNPTR*5 - 4 PACK = PROG (INDEX) NMATCH = N(2) DO 30 I=1,4 30 CVAR(I) = PROG (INDEX + I) LN PTR = LN PTR + 1 RETURN END LOGICAL FUNCTION INPUT(N) C C---------------------------------------------------------------------- C C INPUTS A STRING OF TEXT OF UP TO 72 CHARACTERS FROM CONSOLE. C C WHILE TEXT IS BEING TYPED, THE SYSTEM CONSOLE HANDLER HOLDS C THE INPUT. WHEN A RETURN OR CONTROL-C IS TYPED, THE TEXT IS C THEN AVAILABLE TO THE USER. THIS ROUTINE GETS A CHARACTER C AT A TIME FROM THE HANDLER BY CALLING THE SYSTEM ROUTINE C ITTINR. ON RETURN, IF TEXT IS AVAILABLE, IT IS PUT IN THE C VARIABLE 'STRING' AND 'NCHAR' IS THE NUMBER OF CHARACTERS C TYPED (NOT COUNTING RETURN). IF A CONTROL-C WAS TYPED, NCHAR C WILL HAVE A VALUE OF -1. C C INPUT = .FALSE. IF NO TEXT IS AVAILABLE C = .TRUE. IF TEXT RETURNED 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, I C INPUT = .FALSE. II = ITTINR() IF (II.LT.0) RETURN INPUT = .TRUE. NPTR = 1 NCHAR = 1 I = II 10 IF (I.EQ."15 .OR. I.EQ."12) GO TO 20 IF (I .EQ. 3) GO TO 30 STRING(NCHAR) = I IF (NCHAR .EQ. 71) GO TO 40 NCHAR = NCHAR + 1 I = ITTINR() GO TO 10 20 NCHAR = NCHAR - 1 GO TO 40 30 NCHAR = -1 40 N = NCHAR I = ITTINR() STRING(NCHAR+1) = 0 RETURN END